diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs index 24deb1b6dd9316f7063f8c86ba7fb5d16988066e..35a122a2b3497408897d44014a6a70f6251b44d9 100644 --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -140,6 +140,7 @@ emptyInstalledPackageInfo haddockHTMLs = [] } +noVersion :: Version noVersion = Version{ versionBranch=[], versionTags=[] } -- ----------------------------------------------------------------------------- @@ -147,10 +148,10 @@ noVersion = Version{ versionBranch=[], versionTags=[] } parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo parseInstalledPackageInfo inp = do - lines <- singleStanza inp + stLines <- singleStanza inp -- not interested in stanzas, so just allow blank lines in -- the package info. - foldM (parseBasicStanza fields) emptyInstalledPackageInfo lines + foldM (parseBasicStanza fields) emptyInstalledPackageInfo stLines parseBasicStanza ((StanzaField name _ _ set):fields) pkg (lineNo, f, val) | name == f = set lineNo val pkg @@ -165,19 +166,20 @@ showInstalledPackageInfo :: InstalledPackageInfo -> String showInstalledPackageInfo pkg = render (ppFields fields) where ppFields [] = empty - ppFields ((StanzaField _ get _ _):flds) = get pkg $$ ppFields flds + ppFields ((StanzaField _ get' _ _):flds) = get' pkg $$ ppFields flds showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showInstalledPackageInfoField field - = case [ get | (StanzaField f get _ _) <- fields, f == field ] of + = case [ get' | (StanzaField f get' _ _) <- fields, f == field ] of [] -> Nothing - (get:_) -> Just (render . get) + (get':_) -> Just (render . get') -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing +fields :: [StanzaField InstalledPackageInfo] fields = basicStanzaFields ++ installedStanzaFields basicStanzaFields :: [StanzaField InstalledPackageInfo] diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs index 8d44fcb15f1872fc1e0771bc793cdb41496ca7f9..c6b1e680e54ed1589e8ae8bddb1e67ae8408f3b5 100644 --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -98,7 +98,7 @@ import Distribution.Simple.Utils(currentDir, die) import Distribution.Compat.ReadP as ReadP hiding (get) #ifdef DEBUG -import HUnit (Test(..), assertBool, Assertion, runTestTT) +import HUnit (Test(..), assertBool, Assertion, runTestTT, Counts) import Distribution.ParseUtils (runP) #endif @@ -601,6 +601,7 @@ hasMods pkg_descr -- * Testing -- ------------------------------------------------------------ #ifdef DEBUG +testPkgDesc :: String testPkgDesc = unlines [ "-- Required", "Name: Cabal", @@ -643,6 +644,7 @@ testPkgDesc = unlines [ "Extensions: OverlappingInstances" ] +testPkgDescAnswer :: PackageDescription testPkgDescAnswer = PackageDescription {package = PackageIdentifier {pkgName = "Cabal", pkgVersion = Version {versionBranch = [0,1,1,1,1], @@ -739,5 +741,6 @@ assertParseOk mes expected actual ParseOk v -> v == expected _ -> False) +test :: IO Counts test = runTestTT (TestList hunitTests) #endif diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs index 6dedcca29253c900254424104c206f344da069b0..10bb3638e81b60c44e2bb5aa800656207e4be6e8 100644 --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -165,6 +165,7 @@ splitStanzas = mapM mkStanza . map merge . groupStanzas . filter validLine . zip groupStanzas xs = let (ys,zs) = break allSpaces xs in ys : groupStanzas (dropWhile allSpaces zs) +allSpaces :: (a, String) -> Bool allSpaces (_,xs) = all isSpace xs -- |Split a file into "Field: value" groups, but blank lines have no @@ -177,6 +178,7 @@ singleStanza = mkStanza . merge . filter validLine . zip [1..] . lines [] -> False -- blank line _ -> True +merge :: [(a, [Char])] -> [(a, [Char])] merge ((n,x):(_,c:s):ys) | c == ' ' || c == '\t' = case dropWhile isSpace s of ('.':s') -> merge ((n,x++"\n"++s'):ys) @@ -195,15 +197,15 @@ mkStanza ((n,xs):ys) = return ((n, fld, dropWhile isSpace val):ss) (_, _) -> fail $ "Line "++show n++": Invalid syntax (no colon after field name)" where - checkDuplField fld [] = return () - checkDuplField fld (x'@(n',fld',val'):xs') + checkDuplField _ [] = return () + checkDuplField fld ((n',fld',_):xs') | fld' == fld = fail ("The field "++fld++" is defined on both line "++show n++" and "++show n') | otherwise = checkDuplField fld xs' -- |parse a module name parseModuleNameQ :: ReadP r String -parseModuleNameQ = parseQuoted mod <++ mod - where mod = do +parseModuleNameQ = parseQuoted modu <++ modu + where modu = do c <- satisfy isUpper cs <- munch (\x -> isAlphaNum x || x `elem` "_'.") return (c:cs) diff --git a/Distribution/Setup.hs b/Distribution/Setup.hs index f05a41cf1af81d74c14207874eb94e93d843d3aa..df2db3ddc1cf1ae37e8409592dd6c78ab403ad96 100644 --- a/Distribution/Setup.hs +++ b/Distribution/Setup.hs @@ -220,7 +220,7 @@ parseGlobalArgs args = (flags, _, _, []) | hasHelpFlag flags -> do printGlobalHelp exitWith ExitSuccess - (flags, cname:cargs, _, []) -> do + (_, cname:cargs, _, []) -> do case lookupCommand cname commandList of Just cmd -> return (cmdAction cmd,cargs) Nothing -> do putStrLn $ "Unrecognised command: " ++ cname ++ " (try --help)" diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs index df0c1e625dd85dd928fda6ea58a0c8d6c9d59727..30a7242255f3be3d4eb0aea4d117de4803cf0e6f 100644 --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -233,8 +233,8 @@ buildHugs pkg_descr lbi verbose = do copyModule useCpp bi f (destDir `joinFileName` trimSrcDir f) mapM_ copy_or_cpp (concat fileLists) -- Pass 2: compile foreign stubs in build directory - stubsFileLists <- sequence [moduleToFilePath [destDir] mod suffixes | - mod <- mods] + stubsFileLists <- sequence [moduleToFilePath [destDir] modu suffixes | + modu <- mods] mapM_ (compileFFI bi) (concat stubsFileLists) suffixes = ["hs", "lhs"] diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs index cee43031637c756be227c7f57043493b6a63769a..8d7d0e0146031ec815e91fbbcbb0650933ec9cec 100644 --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -288,13 +288,13 @@ compilerPkgToolName NHC = "hmake" -- FIX: nhc98-pkg Does not yet exist compilerPkgToolName Hugs = "hugs" -- FIX (HUGS): hugs-pkg does not yet exist configCompilerVersion :: CompilerFlavor -> FilePath -> IO Version -configCompilerVersion GHC compiler = +configCompilerVersion GHC compilerPath = withTempFile "." "" $ \tmp -> do - maybeExit $ system (compiler ++ " --version >" ++ tmp) + maybeExit $ system (compilerPath ++ " --version >" ++ tmp) str <- readFile tmp case pCheck (readP_to_S parseVersion (dropWhile (not.isDigit) str)) of [v] -> return v - _ -> die ("cannot determine version of " ++ compiler ++ ":\n " + _ -> die ("cannot determine version of " ++ compilerPath ++ ":\n " ++ str) configCompilerVersion _ _ = return Version{ versionBranch=[],versionTags=[] } @@ -319,11 +319,11 @@ message s = putStrLn $ "configure: " ++ s -- Tests #ifdef DEBUG -packageID = PackageIdentifier "Foo" (Version [1] []) hunitTests :: [Test] hunitTests = [] {- Too specific: +packageID = PackageIdentifier "Foo" (Version [1] []) = [TestCase $ do let simonMarGHCLoc = "/usr/bin/ghc" simonMarGHC <- configure emptyPackageDescription {package=packageID} diff --git a/Distribution/Simple/GHCPackageConfig.hs b/Distribution/Simple/GHCPackageConfig.hs index 8b41ed267690369b0dca56be94b22a026409d38f..fc5b858510f6f21f677f3b5cc611e4d5569477ba 100644 --- a/Distribution/Simple/GHCPackageConfig.hs +++ b/Distribution/Simple/GHCPackageConfig.hs @@ -55,6 +55,7 @@ maybeCreateLocalPackageConfig -- |Helper function for canReadPackageConfig and canWritePackageConfig +checkPermission :: (Permissions -> Bool) -> IO Bool checkPermission perm = do f <- localPackageConfig exists <- doesFileExist f diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs index ad801bfa58d26d0889972b68fc10d9dbb504003f..b076416698892ea6c3be98b9cab4e34e79efd56b 100644 --- a/Distribution/Simple/Install.hs +++ b/Distribution/Simple/Install.hs @@ -62,14 +62,14 @@ module Distribution.Simple.Install ( import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Executable(..), Library (..), - setupMessage, hasLibs, withLib, libModules, withExe, exeModules, + setupMessage, hasLibs, withLib, libModules, withExe, hcOptions) import Distribution.Package (showPackageId, PackageIdentifier(pkgName)) import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..)) import Distribution.Simple.Utils(smartCopySources, copyFileVerbose, mkLibName, die) import Distribution.Setup (CompilerFlavor(..), Compiler(..)) -import Control.Monad(when, unless) +import Control.Monad(when) import Data.Maybe(fromMaybe) import Distribution.Compat.Directory(createDirectoryIfMissing,removeDirectoryRecursive) import Distribution.Compat.FilePath(joinFileName, dllExtension, @@ -143,7 +143,6 @@ installHugs verbose libPref binPref targetLibPref buildPref pkg_descr = do smartCopySources verbose buildPref pkgDir (libModules pkg_descr) hugsInstallSuffixes let progBuildDir = buildPref `joinFileName` "programs" let progInstallDir = libPref `joinFileName` "programs" - let progTargetDir = targetLibPref `joinFileName` "programs" withExe pkg_descr $ \ exe -> do let buildDir = progBuildDir `joinFileName` exeName exe let installDir = progInstallDir `joinFileName` exeName exe diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs index b3821092bd974f22716c136be0118abcb207a2ce..72a20744bff6b42c929b4afec8fc038120a32492 100644 --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -170,8 +170,8 @@ moduleToFilePath pref s possibleSuffixes matchList <- mapM (\x -> do y <- doesFileExist x; return (x, y)) possiblePaths return [x | (x, True) <- matchList] where searchModuleToPossiblePaths :: String -> [String] -> FilePath -> [FilePath] - searchModuleToPossiblePaths s suffs searchP - = moduleToPossiblePaths searchP s suffs + searchModuleToPossiblePaths s' suffs searchP + = moduleToPossiblePaths searchP s' suffs -- |Get the possible file paths based on this module name. moduleToPossiblePaths :: FilePath -- ^search prefix @@ -247,13 +247,13 @@ mkLibName pref lib = pref `joinFileName` ("libHS" ++ lib ++ ".a") withTempFile :: FilePath -> String -> (FilePath -> IO a) -> IO a withTempFile tmp_dir extn action = do x <- getProcessID - findTempName tmp_dir x + findTempName x where - findTempName tmp_dir x + findTempName x = do let filename = ("tmp" ++ show x) `joinFileExt` extn path = tmp_dir `joinFileName` filename b <- doesFileExist path - if b then findTempName tmp_dir (x+1) + if b then findTempName (x+1) else action path `finally` try (removeFile path) #ifdef mingw32_TARGET_OS @@ -344,16 +344,23 @@ stripComments keepPragmas = stripCommentsLevel 0 -- * Finding the description file -- ------------------------------------------------------------ +oldDescFile :: String oldDescFile = "Setup.description" + +cabalExt :: String cabalExt = "cabal" + +buildInfoExt :: String buildInfoExt = "buildinfo" matchesDescFile :: FilePath -> Bool matchesDescFile p = (snd $ splitFileExt p) == cabalExt || p == oldDescFile +noDesc :: IO a noDesc = die $ "No description file found, please create a cabal-formatted description file with the name <pkgname>." ++ cabalExt +multiDesc :: [String] -> IO a multiDesc l = die $ "Multiple description files found. Please use only one of : " ++ show (filter (/= oldDescFile) l) diff --git a/GNUmakefile b/GNUmakefile index 10652f7c2e0ea51f3ce970fe1b492060bec4bebe..be3b1ebeea50a951d62a55769551b1f62cf30cf2 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,5 +1,5 @@ CABALVERSION=0.4 -GHCFLAGS= --make -W -fno-warn-unused-matches -cpp +GHCFLAGS= --make -Wall -fno-warn-unused-matches -cpp # later: -Wall PREF=/usr/local USER_FLAG =