Commit 454e0e9d authored by ijones's avatar ijones
Browse files

lots of changes, mostly from ross

  documentation updates from ross paterson
  - more accurate specification of package names
  - hs-source-dir -> hs-source-dirs in examples
  - setup clean removes a bit more
  - rearrange description of fields

  Version.hs: allow more spaces in version constraints

  Install.hs: add the exe extension when installing executables (reported by Brian Smith)
 
  test directory: add explicit dependencies on base

  Misc:
  Prefix error messages and warnings with the program name, and send them
  to stderr.  (Also moved some stuff from Distribution.Simple.Utils to
  Distribution.Simple.Build to avoid circular dependencies.)

  refactoring only: split Compiler type from Distribution.Setup,
  to reduce dependencies.

  Exclude DefaultSetup.lhs from the GHC build

  add JHC to the Compiler type

  refactored argument processing

  setup sdist --snapshot: append YYYYMMDD to the version for the bundle

  improved error messages (from Brian Smith):
  
  * attach source locations to messages when available
  
  * change some remaining error's do die.

  refactor defaultMainWorker

  split Distribution.Extension between Language.Haskell.Extension (just
  the type, which will also be useful when haskell-src-exts is merged)
  and Distribution.Compiler (mappings to compiler options).

  add Language.Haskell.Extension

  Simon marlow:  update defaults for prefix/libdir/bindir
parent aa44cc66
......@@ -19,6 +19,7 @@ Description:
Category: Distribution
Exposed-Modules:
Distribution.Compat.ReadP,
Distribution.Compiler,
Distribution.Extension,
Distribution.InstalledPackageInfo,
Distribution.License,
......@@ -39,7 +40,8 @@ Exposed-Modules:
Distribution.Simple.SrcDist,
Distribution.Simple.Utils,
Distribution.Compat.FilePath,
Distribution.Version
Distribution.Version,
Language.Haskell.Extension
Other-Modules:
Distribution.GetOpt,
Distribution.Compat.Directory,
......
......@@ -39,155 +39,12 @@ 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. -}
module Distribution.Extension (
Extension(..), Opt,
module Distribution.Extension
{-# DEPRECATED "Use modules Language.Haskell.Extension and Distribution.Compiler instead" #-}
(Extension(..), Opt,
extensionsToNHCFlag, extensionsToGHCFlag, extensionsToHugsFlag,
#ifdef DEBUG
hunitTests
#endif
) where
import Data.List(nub)
#ifdef DEBUG
import HUnit (Test)
#endif
-- ------------------------------------------------------------
-- * Extension
-- ------------------------------------------------------------
-- |This represents non-standard compiler extensions which each
-- package might employ.
data Extension =
OverlappingInstances
| RecursiveDo
| ParallelListComp
| MultiParamTypeClasses
| NoMonomorphismRestriction
| FunctionalDependencies
| RankNTypes
| PolymorphicComponents
| ExistentialQuantification
| ScopedTypeVariables
| ImplicitParams
| FlexibleContexts
| FlexibleInstances
| EmptyDataDecls
| CPP
| TypeSynonymInstances
| TemplateHaskell
| ForeignFunctionInterface
| AllowOverlappingInstances
| AllowUndecidableInstances
| AllowIncoherentInstances
| InlinePhase
| ContextStack
| Arrows
| Generics
| NoImplicitPrelude
| NamedFieldPuns
| PatternGuards
| ExtensibleRecords
| RestrictedTypeSynonyms
| HereDocuments
| UnsafeOverlappingInstances
deriving (Show, Read, Eq)
-- |GHC: Return the unsupported extensions, and the flags for the supported extensions
extensionsToGHCFlag :: [ Extension ] -> ([Extension], [Opt])
extensionsToGHCFlag l
= splitEither $ nub $ map extensionToGHCFlag l
where
extensionToGHCFlag :: Extension -> Either Extension String
extensionToGHCFlag OverlappingInstances = Right "-fallow-overlapping-instances"
extensionToGHCFlag TypeSynonymInstances = Right "-fglasgow-exts"
extensionToGHCFlag TemplateHaskell = Right "-fth"
extensionToGHCFlag ForeignFunctionInterface = Right "-ffi"
extensionToGHCFlag NoMonomorphismRestriction = Right "-fno-monomorphism-restriction"
extensionToGHCFlag AllowOverlappingInstances = Right "-fallow-overlapping-instances"
extensionToGHCFlag AllowUndecidableInstances = Right "-fallow-undecidable-instances"
extensionToGHCFlag AllowIncoherentInstances = Right "-fallow-incoherent-instances"
extensionToGHCFlag InlinePhase = Right "-finline-phase"
extensionToGHCFlag ContextStack = Right "-fcontext-stack"
extensionToGHCFlag Arrows = Right "-farrows"
extensionToGHCFlag Generics = Right "-fgenerics"
extensionToGHCFlag NoImplicitPrelude = Right "-fno-implicit-prelude"
extensionToGHCFlag ImplicitParams = Right "-fimplicit-params"
extensionToGHCFlag CPP = Right "-cpp"
extensionToGHCFlag RecursiveDo = Right "-fglasgow-exts"
extensionToGHCFlag ParallelListComp = Right "-fglasgow-exts"
extensionToGHCFlag MultiParamTypeClasses = Right "-fglasgow-exts"
extensionToGHCFlag FunctionalDependencies = Right "-fglasgow-exts"
extensionToGHCFlag RankNTypes = Right "-fglasgow-exts"
extensionToGHCFlag PolymorphicComponents = Right "-fglasgow-exts"
extensionToGHCFlag ExistentialQuantification = Right "-fglasgow-exts"
extensionToGHCFlag ScopedTypeVariables = Right "-fglasgow-exts"
extensionToGHCFlag FlexibleContexts = Right "-fglasgow-exts"
extensionToGHCFlag FlexibleInstances = Right "-fglasgow-exts"
extensionToGHCFlag EmptyDataDecls = Right "-fglasgow-exts"
extensionToGHCFlag PatternGuards = Right "-fglasgow-exts"
extensionToGHCFlag e@ExtensibleRecords = Left e
extensionToGHCFlag e@RestrictedTypeSynonyms = Left e
extensionToGHCFlag e@HereDocuments = Left e
extensionToGHCFlag e@UnsafeOverlappingInstances = Left e
extensionToGHCFlag e@NamedFieldPuns = Left e
-- |NHC: Return the unsupported extensions, and the flags for the supported extensions
extensionsToNHCFlag :: [ Extension ] -> ([Extension], [Opt])
extensionsToNHCFlag l
= splitEither $ nub $ map extensionToNHCFlag l
where
-- NHC doesn't enforce the monomorphism restriction at all.
extensionToNHCFlag NoMonomorphismRestriction = Right ""
extensionToNHCFlag ForeignFunctionInterface = Right ""
extensionToNHCFlag ExistentialQuantification = Right ""
extensionToNHCFlag EmptyDataDecls = Right ""
extensionToNHCFlag NamedFieldPuns = Right "-puns"
extensionToNHCFlag CPP = Right "-cpp"
extensionToNHCFlag e = Left e
-- |Hugs: Return the unsupported extensions, and the flags for the supported extensions
extensionsToHugsFlag :: [ Extension ] -> ([Extension], [Opt])
extensionsToHugsFlag l
= splitEither $ nub $ map extensionToHugsFlag l
where
extensionToHugsFlag OverlappingInstances = Right "+o"
extensionToHugsFlag UnsafeOverlappingInstances = Right "+O"
extensionToHugsFlag HereDocuments = Right "+H"
extensionToHugsFlag RecursiveDo = Right "-98"
extensionToHugsFlag ParallelListComp = Right "-98"
extensionToHugsFlag MultiParamTypeClasses = Right "-98"
extensionToHugsFlag FunctionalDependencies = Right "-98"
extensionToHugsFlag RankNTypes = Right "-98"
extensionToHugsFlag PolymorphicComponents = Right "-98"
extensionToHugsFlag ExistentialQuantification = Right "-98"
extensionToHugsFlag ScopedTypeVariables = Right "-98"
extensionToHugsFlag ImplicitParams = Right "-98"
extensionToHugsFlag ExtensibleRecords = Right "-98"
extensionToHugsFlag RestrictedTypeSynonyms = Right "-98"
extensionToHugsFlag FlexibleContexts = Right "-98"
extensionToHugsFlag FlexibleInstances = Right "-98"
extensionToHugsFlag ForeignFunctionInterface = Right ""
extensionToHugsFlag EmptyDataDecls = Right ""
extensionToHugsFlag CPP = Right ""
extensionToHugsFlag e = Left e
splitEither :: [Either a b] -> ([a], [b])
splitEither l = ([a | Left a <- l], [b | Right b <- l])
type Opt = String
-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------
#ifdef DEBUG
hunitTests :: [Test]
hunitTests = []
#endif
import Distribution.Compiler (Opt, extensionsToNHCFlag, extensionsToGHCFlag,
extensionsToHugsFlag)
import Language.Haskell.Extension (Extension(..))
......@@ -62,7 +62,7 @@ import Distribution.ParseUtils (
showFilePath, showToken, parseReadS, parseOptVersion, parseQuoted,
showFreeText)
import Distribution.License ( License(..) )
import Distribution.Extension ( Opt )
import Distribution.Compiler ( Opt )
import Distribution.Package ( PackageIdentifier(..), showPackageId,
parsePackageId )
import Distribution.Version ( Version(..), showVersion )
......
......@@ -52,14 +52,13 @@ import Distribution.Package --must not specify imports, since we're exporting mo
import Distribution.PackageDescription
import Distribution.Setup --(parseArgs, Action(..), optionHelpString)
import Distribution.Simple.Utils (maybeExit, defaultPackageDesc)
import Distribution.Simple.Utils (die, maybeExit, defaultPackageDesc)
import Distribution.License (License(..))
import Distribution.Version (Version(..))
import System.Environment(getArgs)
import Data.List ( intersperse )
import System.IO (hPutStrLn, stderr)
import System.Cmd
import System.Exit
......@@ -187,5 +186,4 @@ basicCommand commandName commandCommand commandParseFun = do
no_extra_flags :: [String] -> IO ()
no_extra_flags [] = return ()
no_extra_flags extra_flags =
do hPutStrLn stderr $ "Unrecognised flags: " ++ concat (intersperse "," (extra_flags))
exitWith (ExitFailure 1)
die $ "Unrecognised flags: " ++ concat (intersperse "," (extra_flags))
......@@ -80,12 +80,15 @@ module Distribution.PackageDescription (
#endif
) where
import Control.Monad(liftM, foldM, when, unless)
import Control.Monad(liftM, foldM, when)
import Data.Char
import Data.Maybe(fromMaybe, fromJust, isNothing, catMaybes)
import Data.List (nub)
import Text.PrettyPrint.HughesPJ
import System.Directory(doesFileExist)
import System.Environment(getProgName)
import System.IO(hPutStrLn, stderr)
import System.Exit
import Distribution.ParseUtils
import Distribution.Package(PackageIdentifier(..),showPackageId,
......@@ -94,9 +97,9 @@ import Distribution.Version(Version(..), VersionRange(..),
showVersion, parseVersion)
import Distribution.License(License(..))
import Distribution.Version(Dependency(..))
import Distribution.Extension(Extension(..))
import Distribution.Setup(CompilerFlavor(..))
import Distribution.Simple.Utils(currentDir, die)
import Distribution.Compiler(CompilerFlavor(..))
import Distribution.Simple.Utils(currentDir, die, dieWithLocation, warn)
import Language.Haskell.Extension(Extension(..))
import Distribution.Compat.ReadP as ReadP hiding (get)
......@@ -443,8 +446,11 @@ readAndParseFile parser fpath = do
when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
str <- readFile fpath
case parser str of
ParseFailed e -> error (showError e) -- FIXME
ParseFailed e -> do
let (lineNo, message) = locatedErrorMsg e
dieWithLocation fpath lineNo message
ParseOk x -> return x
where
-- |Parse the given package file.
readPackageDescription :: FilePath -> IO PackageDescription
......@@ -479,12 +485,12 @@ parseDescription inp = do (st:sts) <- splitStanzas inp
where
lib = fromMaybe emptyLibrary (library pkg)
parseExecutableStanza st@((_, "executable",eName):_) =
parseExecutableStanza st@((lineNo, "executable",eName):_) =
case lookupField "main-is" st of
Just (_,_) -> foldM (parseExecutableField executableStanzaFields) emptyExecutable st
Nothing -> fail $ "No 'Main-Is' field found for " ++ eName ++ " stanza"
Nothing -> syntaxError lineNo $ "No 'Main-Is' field found for " ++ eName ++ " stanza"
parseExecutableStanza ((lineNo, f,_):_) =
myError lineNo $ "'Executable' stanza starting with field '" ++ f ++ "'"
syntaxError lineNo $ "'Executable' stanza starting with field '" ++ f ++ "'"
parseExecutableStanza _ = error "This shouldn't happen!"
parseExecutableField ((StanzaField name _ set):fields) exe (lineNo, f, val)
......@@ -521,8 +527,8 @@ parseHookedBuildInfo inp = do
| map toLower inFieldName == "executable"
= do bis <- parseBI bi
return (mName, bis)
| otherwise = myError lineNo "expecting 'executable' at top of stanza"
parseExe [] = myError 0 "error in parsing buildinfo file. Expected executable stanza"
| otherwise = syntaxError lineNo "expecting 'executable' at top of stanza"
parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"
parseBI :: Stanza -> ParseResult BuildInfo
parseBI st = foldM (parseBInfoField binfoFields) emptyBuildInfo st
......@@ -531,7 +537,7 @@ parseBInfoField ((StanzaField name _ set):fields) binfo (lineNo, f, val)
| name == f = set lineNo val binfo
| otherwise = parseBInfoField fields binfo (lineNo, f, val)
parseBInfoField [] _ (lineNo, f, _) =
myError lineNo $ "Unknown field '" ++ f ++ "'"
syntaxError lineNo $ "Unknown field '" ++ f ++ "'"
-- --------------------------------------------
-- ** Pretty printing
......@@ -612,9 +618,11 @@ errorOut :: [String] -- ^Warnings
-> [String] -- ^errors
-> IO ()
errorOut warnings errors = do
mapM (putStrLn . ("Warning: " ++)) warnings
mapM (putStrLn . ("Error: " ++)) errors
unless (null errors) (error "Errors detected. See above.")
mapM warn warnings
when (not (null errors)) $ do
pname <- getProgName
mapM (hPutStrLn stderr . ((pname ++ ": Error: ") ++)) errors
exitWith (ExitFailure 1)
checkMissingFields :: PackageDescription -> [Maybe String]
checkMissingFields pkg_descr =
......
......@@ -44,7 +44,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-- #hide
module Distribution.ParseUtils (
LineNo, PError(..), showError, myError, runP,
LineNo, PError(..), locatedErrorMsg, showError, syntaxError, runP,
ParseResult(..),
StanzaField(..), splitStanzas, Stanza, singleStanza,
parseFilePathQ, parseTokenQ,
......@@ -57,14 +57,14 @@ module Distribution.ParseUtils (
) where
import Text.PrettyPrint.HughesPJ
import Distribution.Compiler (CompilerFlavor)
import Distribution.License
import Distribution.Version
import Distribution.Extension
import Distribution.Package ( parsePackageName )
import Distribution.Compat.ReadP as ReadP hiding (get)
import Distribution.Setup(CompilerFlavor(..))
import Debug.Trace
import Data.Char
import Language.Haskell.Extension (Extension)
-- -----------------------------------------------------------------------------
......@@ -95,14 +95,20 @@ runP lineNo field p s =
_ -> ParseFailed (AmbigousParse field lineNo)
where results = readP_to_S p s
-- TODO: deprecated
showError :: PError -> String
showError (AmbigousParse f n) = "Line "++show n++": Ambigous parse in field '"++f++"'"
showError (NoParse f n) = "Line "++show n++": Parse of field '"++f++"' failed"
showError (FromString s (Just n)) = "Line "++show n++": " ++ s
showError (FromString s Nothing) = s
showError e =
case locatedErrorMsg e of
(Just n, s) -> "Line "++show n++": " ++ s
(Nothing, s) -> s
myError :: LineNo -> String -> ParseResult a
myError n s = ParseFailed $ FromString s (Just n)
locatedErrorMsg :: PError -> (Maybe LineNo, String)
locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambigous parse in field '"++f++"'")
locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed")
locatedErrorMsg (FromString s n) = (n, s)
syntaxError :: LineNo -> String -> ParseResult a
syntaxError n s = ParseFailed $ FromString s (Just n)
data StanzaField a
= StanzaField
......@@ -193,11 +199,11 @@ mkStanza ((n,xs):ys) =
ss <- mkStanza ys
checkDuplField fld ss
return ((n, fld, dropWhile isSpace val):ss)
(_, _) -> fail $ "Line "++show n++": Invalid syntax (no colon after field name)"
(_, _) -> syntaxError n "Invalid syntax (no colon after field name)"
where
checkDuplField _ [] = return ()
checkDuplField fld ((n',fld',_):xs')
| fld' == fld = fail ("The field "++fld++" is defined on both line "++show n++" and "++show n')
| fld' == fld = syntaxError (max n n') $ "The field "++fld++" was already defined on line " ++ show (min n n')
| otherwise = checkDuplField fld xs'
-- |parse a module name
......
......@@ -49,18 +49,17 @@ import Distribution.PreProcess.Unlit(unlit)
import Distribution.PackageDescription (setupMessage, PackageDescription(..),
BuildInfo(..), Executable(..), withExe,
Library(..), withLib, libModules)
import Distribution.Setup (CompilerFlavor(..), Compiler(..))
import Distribution.Compiler (CompilerFlavor(..), Compiler(..))
import Distribution.Simple.Configure (LocalBuildInfo(..))
import Distribution.Simple.Utils (rawSystemPath, rawSystemVerbose,
moduleToFilePath, die)
moduleToFilePath, die, dieWithLocation)
import Distribution.Version (Version(..))
import Control.Monad (unless)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Maybe (fromMaybe)
import Data.List (nub)
import System.Exit (ExitCode(..))
import System.Directory (removeFile, getModificationTime)
import System.Info (os, arch)
import System.IO (stderr, hPutStrLn)
import Distribution.Compat.FilePath
(splitFileExt, joinFileName, joinFileExt)
......@@ -105,7 +104,7 @@ preprocessSources pkg_descr lbi verbose handlers = do
sequence_ [do retVal <- preprocessModule (hsSourceDirs bi) modu
verbose builtinSuffixes biHandlers
unless (retVal == ExitSuccess)
(error $ "got error code while preprocessing: " ++ modu)
(die $ "got error code while preprocessing: " ++ modu)
| modu <- libModules pkg_descr]
unless (null (executables pkg_descr)) $
setupMessage "Preprocessing executables for" pkg_descr
......@@ -116,7 +115,7 @@ preprocessSources pkg_descr lbi verbose handlers = do
++(maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)))
modu verbose builtinSuffixes biHandlers
unless (retVal == ExitSuccess)
(error $ "got error code while preprocessing: " ++ modu)
(die $ "got error code while preprocessing: " ++ modu)
| modu <- otherModules bi]
where hc = compilerFlavor (compiler lbi)
builtinSuffixes
......@@ -209,7 +208,11 @@ ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor
ppCpp' inputArgs bi lbi
= maybe (ppNone "cpphs") pp (withCpphs lbi)
where pp cpphs inFile outFile verbose
#if __HUGS__ && mingw32_TARGET_OS
= rawSystemVerbose verbose "sh" (cpphs : extraArgs ++ ["-O" ++ outFile, inFile])
#else
= rawSystemVerbose verbose cpphs (extraArgs ++ ["-O" ++ outFile, inFile])
#endif
extraArgs = "--noline" : "--strip" :
sysDefines ++ cppOptions bi lbi ++ inputArgs
sysDefines =
......@@ -220,7 +223,11 @@ ppCpp' inputArgs bi lbi
ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
ppHsc2hs bi lbi
= maybe (ppNone "hsc2hs") pp (withHsc2hs lbi)
#if __HUGS__ && mingw32_TARGET_OS
where pp n = standardPP "sh" (n : cppOptions bi lbi)
#else
where pp n = standardPP n (cppOptions bi lbi)
#endif
ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
ppC2hs bi lbi
......@@ -267,9 +274,8 @@ standardPP eName args inFile outFile verbose
= rawSystemVerbose verbose eName (args ++ ["-o", outFile, inFile])
ppNone :: String -> PreProcessor
ppNone name inFile _ _ = do
hPutStrLn stderr (inFile ++ ": no " ++ name ++ " preprocessor available")
return (ExitFailure 1)
ppNone name inFile _ _ =
dieWithLocation inFile Nothing $ "no " ++ name ++ " preprocessor available"
-- |Convenience function; get the suffixes of these preprocessors.
ppSuffixes :: [ PPSuffixHandler ] -> [String]
......
......@@ -41,9 +41,9 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Setup (--parseArgs,
module Distribution.Compiler,
Action(..), ConfigFlags(..),
CopyFlags, InstallFlags, RegisterFlags,
CompilerFlavor(..), Compiler(..),
--optionHelpString,
#ifdef DEBUG
hunitTests,
......@@ -55,31 +55,19 @@ module Distribution.Setup (--parseArgs,
parseUnregisterArgs, parseCopyArgs
) where
-- Misc:
#ifdef DEBUG
import HUnit (Test(..))
#endif
import Control.Monad(when)
import Distribution.Version (Version)
import Distribution.Compiler
import Distribution.Simple.Utils (die)
import Data.List(find)
import Distribution.GetOpt
import System.Exit
import System.Environment
-- ------------------------------------------------------------
-- * Command Line Types and Exports
-- ------------------------------------------------------------
data CompilerFlavor = GHC | NHC | Hugs | HBC | Helium | OtherCompiler String
deriving (Show, Read, Eq)
data Compiler = Compiler {compilerFlavor:: CompilerFlavor,
compilerVersion :: Version,
compilerPath :: FilePath,
compilerPkgTool :: FilePath}
deriving (Show, Read, Eq)
-- type CommandLineOpts = (Action,
-- [String]) -- The un-parsed remainder
......@@ -155,6 +143,8 @@ data Flag a = GhcFlag | NhcFlag | HugsFlag
| GenScriptFlag
-- For copy:
| InstPrefix FilePath
-- For sdist:
| Snapshot
-- For everyone:
| HelpFlag
| Verbose Int
......@@ -183,9 +173,6 @@ liftCustomOpts flags = [ Option shopt lopt (f adesc) help
f (ReqArg g s) = ReqArg (Lift . g) s
f (OptArg g s) = OptArg (Lift . g) s
unliftFlags :: [Flag a] -> [a]
unliftFlags flags = [ fl | Lift fl <- flags ]
data Cmd a = Cmd {
cmdName :: String,
cmdHelp :: String, -- Short description
......@@ -239,13 +226,9 @@ parseGlobalArgs args =
(_, cname:cargs, _, []) -> do
case lookupCommand cname commandList of
Just cmd -> return (cmdAction cmd,cargs)
Nothing -> do putStrLn $ "Unrecognised command: " ++ cname ++ " (try --help)"
exitWith (ExitFailure 1)
(_, [], _, []) -> do putStrLn $ "No command given (try --help)"
exitWith (ExitFailure 1)
(_, _, _, errs) -> do putStrLn "Errors:"
mapM_ putStrLn errs
exitWith (ExitFailure 1)
Nothing -> die $ "Unrecognised command: " ++ cname ++ " (try --help)"
(_, [], _, []) -> die $ "No command given (try --help)"
(_, _, _, errs) -> putErrors errs
configureCmd :: Cmd a
configureCmd = Cmd {
......@@ -294,6 +277,7 @@ configureCmd = Cmd {
parseConfigureArgs :: ConfigFlags -> [String] -> [OptDescr a] ->
IO (ConfigFlags, [a], [String])
<<<<<<< Setup.hs
parseConfigureArgs cfg args customOpts =
case getCmdOpt configureCmd customOpts args of
(flags, _, []) | hasHelpFlag flags -> do
......@@ -329,6 +313,29 @@ parseConfigureArgs cfg args customOpts =
Lift _ -> t
_ -> error $ "Unexpected flag!"
updateCfg [] t = t
=======
parseConfigureArgs = parseArgs configureCmd updateCfg
where updateCfg t GhcFlag = t { configHcFlavor = Just GHC }
updateCfg t NhcFlag = t { configHcFlavor = Just NHC }
updateCfg t HugsFlag = t { configHcFlavor = Just Hugs }
updateCfg t (WithCompiler path) = t { configHcPath = Just path }
updateCfg t (WithHcPkg path) = t { configHcPkg = Just path }
updateCfg t (WithHaddock path) = t { configHaddock = Just path }
updateCfg t (WithHappy path) = t { configHappy = Just path }
updateCfg t (WithAlex path) = t { configAlex = Just path }
updateCfg t (WithHsc2hs path) = t { configHsc2hs = Just path }
updateCfg t (WithC2hs path) = t { configC2hs = Just path }
updateCfg t (WithCpphs path) = t { configCpphs = Just path }
updateCfg t WithProfLib = t { configProfLib = True }
updateCfg t WithoutProfLib = t { configProfLib = False }
updateCfg t WithProfExe = t { configProfExe = True }
updateCfg t WithoutProfExe = t { configProfExe = False }
updateCfg t (Prefix path) = t { configPrefix = Just path }
updateCfg t (Verbose n) = t { configVerbose = n }
updateCfg t UserFlag = t { configUser = True }
updateCfg t GlobalFlag = t { configUser = False }
updateCfg t _ = error $ "Unexpected flag!"
>>>>>>> 1.37
buildCmd :: Cmd a
buildCmd = Cmd {
......@@ -411,64 +418,46 @@ type CopyFlags = (Maybe FilePath,Int)
parseCopyArgs :: CopyFlags -> [String] -> [OptDescr a] ->
IO (CopyFlags, [a], [String])
parseCopyArgs cfg args customOpts =
case getCmdOpt copyCmd customOpts args of
(flags, _, []) | hasHelpFlag flags -> do
printCmdHelp copyCmd customOpts
exitWith ExitSuccess
(flags, args', []) ->
return (updateCfg flags cfg, unliftFlags flags, args')
(_, _, errs) -> do putStrLn "Errors: "
mapM_ putStrLn errs
exitWith (ExitFailure 1)
where updateCfg (fl:flags) (mprefix,verbose) = updateCfg flags $
case fl of
InstPrefix path -> (Just path,verbose)
Verbose n -> (mprefix,n)
Lift _ -> (mprefix,verbose)
parseCopyArgs = parseArgs copyCmd updateCfg
where updateCfg (mprefix,verbose) fl = case fl of
InstPrefix path -> (Just path, verbose)
Verbose n -> (mprefix, n)
_ -> error $ "Unexpected flag!"
updateCfg [] t = t
-- | Flags to @install@: (user package, verbose)
type InstallFlags = (Bool,Int)
parseInstallArgs :: InstallFlags -> [String] -> [OptDescr a] ->
IO (InstallFlags, [a], [String])
parseInstallArgs cfg args customOpts =
case getCmdOpt installCmd customOpts args of
(flags, _, []) | hasHelpFlag flags -> do
printCmdHelp installCmd customOpts
exitWith ExitSuccess
(flags, args', []) ->
when (any isInstallPref flags) (error "--install-prefix is deprecated. Use copy command instead.") >>
return (updateCfg flags cfg, unliftFlags flags, args')
(_, _