diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,5 +1,5 @@ Name: Cabal -Version: 1.8.0.2 +Version: 1.8.0.4 Copyright: 2003-2006, Isaac Jones 2005-2009, Duncan Coutts License: BSD3 @@ -32,7 +32,7 @@ source-repository this type: darcs location: http://darcs.haskell.org/cabal-branches/cabal-1.8/ - tag: 1.8.0.2 + tag: 1.8.0.4 Flag base4 Description: Choose the even newer, even smaller, split-up base package. @@ -54,12 +54,12 @@ pretty >= 1 && < 1.1 if !os(windows) - Build-Depends: unix >= 2.1 && < 2.5 + Build-Depends: unix >= 2.0 && < 2.5 ghc-options: -Wall -fno-ignore-asserts if impl(ghc >= 6.8) ghc-options: -fwarn-tabs - cpp-options: "-DCABAL_VERSION=1,8,0,2" + cpp-options: "-DCABAL_VERSION=1,8,0,4" nhc98-Options: -K4M Exposed-Modules: diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs --- a/Distribution/Compat/Exception.hs +++ b/Distribution/Compat/Exception.hs @@ -5,7 +5,7 @@ {-# OPTIONS_NHC98 -cpp #-} {-# OPTIONS_JHC -fcpp #-} -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 609) +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) #define NEW_EXCEPTION #endif diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs --- a/Distribution/Compat/ReadP.hs +++ b/Distribution/Compat/ReadP.hs @@ -248,7 +248,8 @@ -- ^ Parses the first one or more characters satisfying the predicate. munch1 p = do c <- get - if p c then do s <- munch p; return (c:s) else pfail + if p c then do s <- munch p; return (c:s) + else pfail choice :: [ReadP r a] -> ReadP r a -- ^ Combines all parsers in the specified list. diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs --- a/Distribution/Compat/TempFile.hs +++ b/Distribution/Compat/TempFile.hs @@ -21,6 +21,7 @@ Handle, IOMode(ReadWriteMode)) import System.Directory (doesFileExist) import System.FilePath ((<.>), splitExtension) +import System.IO.Error (try, isAlreadyExistsError) #else import System.IO (Handle, openTempFile, openBinaryTempFile) import Data.Bits ((.|.)) diff --git a/Distribution/ModuleName.hs b/Distribution/ModuleName.hs --- a/Distribution/ModuleName.hs +++ b/Distribution/ModuleName.hs @@ -88,7 +88,7 @@ -- XXX This is used in Distribution/Simple/PreProcess.hs, so we can't -- deprecate it yet without getting warnings, and thus build failures --- {-# DEPRECATED simple "use ModuleName.fromString instead" #-} +{-# DEPRECATED simple "use ModuleName.fromString instead" #-} simple :: String -> ModuleName simple str = ModuleName [str] diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -443,19 +443,21 @@ "'ghc-options: -d*' debug flags are not appropriate for a distributed package." , checkFlags ["-prof"] $ - PackageDistInexcusable $ - "'ghc-options: -prof' is not needed. Use the --enable-library-profiling configure flag." + PackageBuildWarning $ + "'ghc-options: -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-executable-profiling." , checkFlags ["-o"] $ - PackageDistInexcusable $ - "'ghc-options: -o' is not allowed. The output files are named automatically." + PackageBuildWarning $ + "'ghc-options: -o' is not needed. The output files are named automatically." , checkFlags ["-hide-package"] $ - PackageDistInexcusable $ + PackageBuildWarning $ "'ghc-options: -hide-package' is never needed. Cabal hides all packages." , checkFlags ["--make"] $ - PackageDistInexcusable $ + PackageBuildWarning $ "'ghc-options: --make' is never needed. Cabal uses this automatically." , checkFlags ["-main-is"] $ @@ -477,7 +479,7 @@ ++ "and not just imposing longer compile times on your users." , checkFlags ["-split-objs"] $ - PackageDistInexcusable $ + PackageBuildWarning $ "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." , checkFlags ["-optl-Wl,-s", "-optl-s"] $ @@ -756,7 +758,7 @@ requiresAtLeast = case cabalVersionIntervals of (LowerBound ver' _,_):_ -> (ver' >=) _ -> const False - where cabalVersionIntervals = asVersionIntervals (descCabalVersion pkg) + where cabalVersionIntervals = asVersionIntervals (descCabalVersion pkg) dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) @@ -1067,7 +1069,7 @@ Left err -> Just err Right [] -> Nothing Right (_:_) -> Just noSplit - where + where -- drop the '/' between the name and prefix: remainder = init first : rest diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs --- a/Distribution/PackageDescription/Configuration.hs +++ b/Distribution/PackageDescription/Configuration.hs @@ -65,9 +65,7 @@ , Flag(..), FlagName(..), FlagAssignment , CondTree(..), ConfVar(..), Condition(..) ) import Distribution.Version - ( VersionRange, anyVersion, intersectVersionRanges, withinRange - , toVersionIntervals, intersectVersionIntervals - , fromVersionIntervals ) + ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler ( CompilerId(CompilerId) ) import Distribution.System @@ -81,7 +79,6 @@ import Control.Arrow (first) import qualified Distribution.Compat.ReadP as ReadP ( char ) -import Control.Exception (assert) import Data.Char ( isAlphaNum ) import Data.Maybe ( catMaybes, maybeToList ) import Data.Map ( Map, fromListWith, toList ) @@ -489,29 +486,13 @@ Right ((mlib, exes'), targetSet, flagVals) -> Right ( pkg { library = mlib , executables = exes' - , buildDepends = assert sanity overallDeps + , buildDepends = fromDepMap (overallDependencies targetSet) + --TODO: we need to find a way to avoid pulling in deps + -- for non-buildable components. However cannot simply + -- filter at this stage, since if the package were not + -- available we would have failed already. } , flagVals ) - where - -- Note that we exclude non-buildable components. This means your tools and - -- test progs to not contribute to the overall package dependencies. - -- - overallDeps = canonicalise - . concatMap targetBuildDepends - . filter buildable - $ buildInfos - buildInfos = map libBuildInfo (maybeToList mlib) ++ map buildInfo exes' - - -- as a sanity check, check that the overall deps from the target set - -- matches those from the (unfiltered for being buildable) components - sanity = canonicalise overallDeps' == canonicalise overallDeps'' - overallDeps' = concatMap targetBuildDepends buildInfos - overallDeps'' = fromDepMap (overallDependencies targetSet) - canonicalise = - map (\(name, vi) -> Dependency name (fromVersionIntervals vi)) - . Map.toList - . Map.fromListWith intersectVersionIntervals - . map (\(Dependency name vr) -> (name, toVersionIntervals vr)) Left missing -> Left missing where diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -515,7 +515,7 @@ (fieldValue rest' followingLines) rest' -> do ts' <- mapM (mkField (d+1)) ts return (Section n (map toLower name) rest' ts') - where fieldValue firstLine followingLines = + where fieldValue firstLine followingLines = let firstLine' = trimLeading firstLine followingLines' = map (\(_,_,s) -> stripDot s) followingLines allLines | null firstLine' = followingLines' diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -62,12 +62,13 @@ import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule import Distribution.Package - ( Package(..) ) + ( Package(..), PackageId, InstalledPackageId(..) ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..) , Library(..), Executable(..) ) +import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Setup @@ -80,7 +81,7 @@ import Distribution.Simple.BuildPaths ( autogenModulesDir, autogenModuleName, cppHeaderName ) import Distribution.Simple.Register - ( registerPackage, generateRegistrationInfo ) + ( registerPackage, inplaceInstalledPackageInfo ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, rewriteFile , die, info, setupMessage ) @@ -96,6 +97,8 @@ ( unless ) import System.FilePath ( (), (<.>) ) +import System.Directory + ( getCurrentDirectory ) -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package. @@ -117,11 +120,15 @@ info verbosity "Building library..." buildLib verbosity pkg_descr lbi lib clbi - installedPkgInfo <- generateRegistrationInfo verbosity pkg_descr lib - lbi clbi True{-inplace-} distPref - -- Register the library in-place, so exes can depend -- on internally defined libraries. + pwd <- getCurrentDirectory + let installedPkgInfo = + (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) { + -- The inplace registration uses the "-inplace" suffix, + -- not an ABI hash. + IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo) + } registerPackage verbosity installedPkgInfo pkg_descr lbi True{-inplace-} internalPackageDB @@ -131,6 +138,10 @@ withExeLBI pkg_descr lbi' $ \exe clbi -> do info verbosity $ "Building executable " ++ exeName exe ++ "..." buildExe verbosity pkg_descr lbi' exe clbi + +-- Quick hack in 1.8 branch, it's done properly in HEAD +inplacePackageId :: PackageId -> InstalledPackageId +inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") -- | Initialize a new package db file for libraries defined -- internally to the package. diff --git a/Distribution/Simple/Build/Macros.hs b/Distribution/Simple/Build/Macros.hs --- a/Distribution/Simple/Build/Macros.hs +++ b/Distribution/Simple/Build/Macros.hs @@ -40,10 +40,10 @@ "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : [ concat ["/* package ",display pkgid," */\n" - ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) \\\n" + ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" ," (major1) < ",major1," || \\\n" ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" ,"\n\n" ] | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi diff --git a/Distribution/Simple/Build/PathsModule.hs b/Distribution/Simple/Build/PathsModule.hs --- a/Distribution/Simple/Build/PathsModule.hs +++ b/Distribution/Simple/Build/PathsModule.hs @@ -151,6 +151,7 @@ absolute = hasLibs pkg_descr -- we can only make progs relocatable || isNothing flat_bindirrel -- if the bin dir is an absolute path + || (isHugs && isNothing flat_progdirrel) || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) supportsRelocatableProgs Hugs = True diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs --- a/Distribution/Simple/Command.hs +++ b/Distribution/Simple/Command.hs @@ -382,7 +382,7 @@ commonFlags showOrParseArgs = case showOrParseArgs of ShowArgs -> [help] ParseArgs -> [help, list] - where + where help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) "Show this help text" helpShortFlags = case showOrParseArgs of @@ -475,9 +475,9 @@ [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs) _ -> CommandReadyToGo (flags, badCommand name) [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) + where flags = mkflags (commandDefaultFlags globalCommand) - where + where lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands' , cname'==cname ] noCommand = CommandErrors ["no command given (try --help)\n"] @@ -521,7 +521,7 @@ _ -> CommandHelp globalHelp _ -> badCommand name - where globalHelp = commandHelp globalCommand' + where globalHelp = commandHelp globalCommand' helpCommandUI = (makeCommand "help" "Help about commands" Nothing () (const [])) { commandUsage = \pname -> diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -364,16 +364,7 @@ (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) . map (selectDependency internalPackageSet installedPackageSet) - (failedDeps, allPkgDeps) = case flavor of - GHC -> selectDependencies (buildDepends pkg_descr) - JHC -> selectDependencies (buildDepends pkg_descr) - LHC -> selectDependencies (buildDepends pkg_descr) - _ -> ([], bogusSelection) - where - bogusSelection :: [ResolvedDependency] - bogusSelection = zipWith ExternalDependency - (buildDepends pkg_descr) - bogusDependencies + (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ] @@ -428,9 +419,11 @@ -- check extensions let extlist = nub $ concatMap extensions (allBuildInfo pkg_descr) let exts = unsupportedExtensions comp extlist - unless (null exts) $ warn verbosity $ -- Just warn, FIXME: Should this be an error? - display flavor ++ " does not support the following extensions: " ++ - intercalate ", " (map display exts) + when (not (null exts)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display exts) let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) programsConfig'' <- @@ -462,7 +455,7 @@ if newPackageDepsBehaviour pkg_descr' then [ (installedPackageId pkg, packageId pkg) | pkg <- selectSubset bi externalPkgDeps ] - ++ [ (InstalledPackageId (display pkgid), pkgid) + ++ [ (inplacePackageId pkgid, pkgid) | pkgid <- selectSubset bi internalPkgDeps ] else [ (installedPackageId pkg, packageId pkg) | pkg <- externalPkgDeps ] @@ -538,6 +531,10 @@ in pkg_descr{ library = modifyLib `fmap` library pkg_descr , executables = modifyExecutable `map` executables pkg_descr} +-- Quick hack in 1.8 branch, it's done properly in HEAD +inplacePackageId :: PackageId -> InstalledPackageId +inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") + -- ----------------------------------------------------------------------------- -- Configuring package dependencies @@ -638,8 +635,10 @@ info verbosity "Reading installed packages..." case compilerFlavor comp of GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDBs progconf + Hugs-> Just `fmap`Hugs.getInstalledPackages verbosity packageDBs progconf JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDBs progconf LHC -> Just `fmap` LHC.getInstalledPackages verbosity packageDBs progconf + NHC -> Just `fmap` NHC.getInstalledPackages verbosity packageDBs progconf _ -> return Nothing -- | Currently the user interface specifies the package dbs to use with just a diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -83,8 +83,9 @@ import Distribution.Simple.PackageIndex (PackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) -import Distribution.Simple.InstallDirs + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..), + absoluteInstallDirs ) +import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package @@ -115,6 +116,7 @@ import Language.Haskell.Extension (Extension(..)) import Control.Monad ( unless, when ) +import Data.Char ( isSpace ) import Data.List import Data.Maybe ( catMaybes ) import Data.Monoid ( Monoid(..) ) @@ -200,21 +202,29 @@ configureToolchain ghcProg = addKnownProgram gccProgram { programFindLocation = findProg gccProgram - [ baseDir "gcc.exe", - mingwDir "bin" "gcc.exe" ], + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "gcc.exe" + else baseDir "gcc.exe" ], programPostConf = configureGcc } . addKnownProgram ldProgram { programFindLocation = findProg ldProgram - [ libDir "ld.exe", - mingwDir "mingw32" "bin" "ld.exe" ], + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "ld.exe" + else libDir "ld.exe" ], programPostConf = configureLd } + . addKnownProgram arProgram { + programFindLocation = findProg arProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "ar.exe" + else libDir "ar.exe" ] + } where Just ghcVersion = programVersion ghcProg compilerDir = takeDirectory (programPath ghcProg) baseDir = takeDirectory compilerDir - mingwDir = baseDir "mingw" + mingwBinDir = baseDir "mingw" "bin" libDir = baseDir "gcc-lib" includeDir = baseDir "include" "mingw" isWindows = case buildOS of Windows -> True; _ -> False @@ -352,6 +362,7 @@ getInstalledPackages verbosity packagedbs conf = do checkPackageDbStack packagedbs pkgss <- getInstalledPackages' verbosity packagedbs conf + topDir <- ghcLibDir' verbosity ghcProg let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] return $! hackRtsPackage (mconcat indexes) @@ -361,8 +372,6 @@ -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it Just ghcProg = lookupProgram ghcProgram conf - compilerDir = takeDirectory (programPath ghcProg) - topDir = takeDirectory compilerDir hackRtsPackage index = case PackageIndex.lookupPackageName index (PackageName "rts") of @@ -371,6 +380,11 @@ _ -> index -- No (or multiple) ghc rts package is registered!! -- Feh, whatever, the ghc testsuite does some crazy stuff. +ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +ghcLibDir' verbosity ghcProg = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] + checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () @@ -521,6 +535,9 @@ sharedLibFilePath = libTargetDir mkSharedLibName pkgid (compilerId (compiler lbi)) ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest + sharedLibInstallPath = libInstallPath mkSharedLibName pkgid + (compilerId (compiler lbi)) stubObjs <- fmap catMaybes $ sequence [ findFileWithExtension [objExtension] [libTargetDir] @@ -579,6 +596,11 @@ "-shared", "-dynamic", "-o", sharedLibFilePath ] + -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. + ++ (if buildOS == OSX + then ["-dylib-install-name", sharedLibInstallPath] + else []) ++ dynamicObjectFiles ++ ["-package-name", display pkgid ] ++ ghcPackageFlags lbi clbi @@ -786,15 +808,14 @@ ghcPackageDbOptions :: PackageDBStack -> [String] ghcPackageDbOptions dbstack = case dbstack of - (GlobalPackageDB:dbs) - | UserPackageDB `elem` dbs -> concatMap specific dbs - | otherwise -> "-no-user-package-conf" - : concatMap specific dbs - _ -> ierror + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror where specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = [] - ierror = error "internal error: unexpected package db stack" + specific _ = ierror + ierror = error "internal error: unexpected package db stack" constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> Verbosity -> Bool diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs --- a/Distribution/Simple/Hugs.hs +++ b/Distribution/Simple/Hugs.hs @@ -2,6 +2,7 @@ -- | -- Module : Distribution.Simple.Hugs -- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable @@ -41,24 +42,39 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Hugs ( - configure, - buildLib, - buildExe, - install - ) where + configure, + getInstalledPackages, + buildLib, + buildExe, + install + ) where +import Distribution.Package + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , emptyInstalledPackageInfo, parseInstalledPackageInfo ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), hcOptions, Executable(..), withExe, Library(..), withLib, libModules ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag ) -import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, - requireProgram, rawSystemProgramConf, - ffihugsProgram, hugsProgram ) + ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag + , PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.Program + ( Program(programFindVersion) + , ProgramConfiguration, userMaybeSpecifyPath + , requireProgram, requireProgramVersion + , rawSystemProgramConf, programPath + , ffihugsProgram, hugsProgram ) import Distribution.Version - ( Version(..) ) + ( Version(..), orLaterVersion ) import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) import Distribution.Simple.PreProcess.Unlit ( unlit ) @@ -71,6 +87,7 @@ ( createDirectoryIfMissingVerbose, installOrdinaryFiles , withUTF8FileContents, writeFileAtomic, copyFileVerbose , findFile, findFileWithExtension, findModuleFiles + , rawSystemStdInOut , die, info, notice ) import Language.Haskell.Extension ( Extension(..) ) @@ -79,14 +96,21 @@ import Distribution.System ( OS(..), buildOS ) import Distribution.Text - ( display ) + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) import Distribution.Verbosity import Data.Char ( isSpace ) import Data.Maybe ( mapMaybe, catMaybes ) +import Data.Monoid ( Monoid(..) ) import Control.Monad ( unless, when, filterM ) import Data.List ( nub, sort, isSuffixOf ) -import System.Directory ( removeDirectoryRecursive ) +import System.Directory + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeDirectoryRecursive, getHomeDirectory ) +import System.Exit + ( ExitCode(ExitSuccess) ) import Distribution.Compat.CopyFile ( setFileExecutable ) import Distribution.Compat.Exception @@ -100,14 +124,46 @@ (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram (userMaybeSpecifyPath "ffihugs" hcPath conf) - (_hugsProg, conf'') <- requireProgram verbosity hugsProgram conf' + (_hugsProg, version, conf'') + <- requireProgramVersion verbosity hugsProgram' + (orLaterVersion (Version [2006] [])) conf' let comp = Compiler { - compilerId = CompilerId Hugs (Version [] []), + compilerId = CompilerId Hugs version, compilerExtensions = hugsLanguageExtensions } return (comp, conf'') + where + hugsProgram' = hugsProgram { programFindVersion = getVersion } + +getVersion :: Verbosity -> FilePath -> IO (Maybe Version) +getVersion verbosity hugsPath = do + (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath [] + (Just (":quit", False)) False + if exit == ExitSuccess + then return $! findVersion output + else return Nothing + + where + findVersion output = do + (monthStr, yearStr) <- selectWords output + year <- convertYear yearStr + month <- convertMonth monthStr + return (Version [year, month] []) + + selectWords output = + case [ (month, year) + | [_,_,"Version:", month, year,_] <- map words (lines output) ] of + [(month, year)] -> Just (month, year) + _ -> Nothing + convertYear year = case reads year of + [(y, [])] | y >= 1999 && y < 2020 -> Just y + _ -> Nothing + convertMonth month = lookup month (zip months [1..]) + months = [ "January", "February", "March", "April", "May", "June", "July" + , "August", "September", "October", "November", "December" ] + -- | The flags for the supported extensions hugsLanguageExtensions :: [(Extension, Flag)] hugsLanguageExtensions = @@ -132,6 +188,114 @@ ,(EmptyDataDecls , "") ,(CPP , "") ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (hugsProg, _) <- requireProgram verbosity hugsProgram conf + let bindir = takeDirectory (programPath hugsProg) + libdir = takeDirectory bindir "lib" "hugs" + dbdirs = nub (concatMap (packageDbPaths homedir libdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths home hugslibdir db = case db of + GlobalPackageDB -> [ hugslibdir "packages" + , "/usr/local/lib/hugs/packages" ] + UserPackageDB -> [ home "lib/hugs/packages" ] + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let pathsModule = pkgdir ("Paths_" ++ display pkgname) <.> "hs" + pathsModuleExists <- doesFileExist pathsModule + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of Hugs which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the Paths_pkgname.hs file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the Paths_pkgname.hs file, looking for a line like: + -- + -- > version = Version {versionBranch = [2,0], versionTags = []} + -- + -- and parse it using 'Read'. Yes we are that evil. + -- + extractVersion content = + case [ version + | ("version":"=":rest) <- map words (lines content) + , (version, []) <- reads (concat rest) ] of + [version] -> Just version + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo -- ----------------------------------------------------------------------------- -- Building diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -216,7 +216,7 @@ -- Default installation directories defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs comp userInstall hasLibs = do +defaultInstallDirs comp userInstall _hasLibs = do windowsProgramFilesDir <- getWindowsProgramFilesDir userInstallPrefix <- getAppUserDataDirectory "cabal" lhcPrefix <- getAppUserDataDirectory "lhc" @@ -244,13 +244,10 @@ progdir = "$libdir" "hugs" "programs", includedir = "$libdir" "$libsubdir" "include", datadir = case buildOS of - Windows | hasLibs -> windowsProgramFilesDir "Haskell" - | otherwise -> "$prefix" + Windows -> "$prefix" _other -> "$prefix" "share", datasubdir = "$pkgid", - docdir = case buildOS of - Windows -> "$prefix" "doc" "$pkgid" - _other -> "$datadir" "doc" "$pkgid", + docdir = "$datadir" "doc" "$pkgid", mandir = "$datadir" "man", htmldir = "$docdir" "html", haddockdir = "$htmldir" @@ -443,7 +440,7 @@ ] platformTemplateEnv :: Platform -> PathTemplateEnv -platformTemplateEnv (Platform os arch) = +platformTemplateEnv (Platform arch os) = [(OSVar, PathTemplate [Ordinary $ display os]) ,(ArchVar, PathTemplate [Ordinary $ display arch]) ] diff --git a/Distribution/Simple/LHC.hs b/Distribution/Simple/LHC.hs --- a/Distribution/Simple/LHC.hs +++ b/Distribution/Simple/LHC.hs @@ -654,7 +654,7 @@ (GlobalPackageDB:dbs) -> "-no-user-package-conf" : concatMap specific dbs _ -> ierror - where + where specific (SpecificPackageDB db) = [ "-package-conf", db ] specific _ = ierror ierror = error "internal error: unexpected package db stack" diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs --- a/Distribution/Simple/NHC.hs +++ b/Distribution/Simple/NHC.hs @@ -2,6 +2,7 @@ -- | -- Module : Distribution.Simple.NHC -- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable @@ -40,14 +41,23 @@ (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.Simple.NHC - ( configure - , buildLib, buildExe - , installLib, installExe +module Distribution.Simple.NHC ( + configure, + getInstalledPackages, + buildLib, + buildExe, + installLib, + installExe, ) where import Distribution.Package - ( PackageIdentifier, packageName, Package(..) ) + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageId, packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , emptyInstalledPackageInfo, parseInstalledPackageInfo ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) , hcOptions ) @@ -59,7 +69,9 @@ ( mkLibName, objExtension, exeExtension ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , Flag, extensionsToFlags ) + , Flag, extensionsToFlags, PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) import Language.Haskell.Extension ( Extension(..) ) import Distribution.Simple.Program @@ -70,19 +82,25 @@ import Distribution.Simple.Utils ( die, info, findFileWithExtension, findModuleFiles , installOrdinaryFile, installExecutableFile, installOrdinaryFiles - , createDirectoryIfMissingVerbose ) + , createDirectoryIfMissingVerbose, withUTF8FileContents ) import Distribution.Version ( Version(..), orLaterVersion ) import Distribution.Verbosity import Distribution.Text - ( display ) + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) import System.FilePath ( (), (<.>), normalise, takeDirectory, dropExtension ) import System.Directory - ( removeFile ) + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeFile, getHomeDirectory ) +import Data.Char ( toLower ) import Data.List ( nub ) +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) import Control.Monad ( when, unless ) import Distribution.Compat.Exception @@ -121,6 +139,7 @@ nhcLanguageExtensions = -- TODO: use -98 when no extensions are specified. -- NHC doesn't enforce the monomorphism restriction at all. + -- TODO: pattern guards in 1.20 [(NoMonomorphismRestriction, "") ,(ForeignFunctionInterface, "") ,(ExistentialQuantification, "") @@ -128,6 +147,118 @@ ,(NamedFieldPuns, "-puns") ,(CPP, "-cpp") ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (nhcProg, _) <- requireProgram verbosity nhcProgram conf + let bindir = takeDirectory (programPath nhcProg) + incdir = takeDirectory bindir "include" "nhc98" + dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths _home incdir db = case db of + GlobalPackageDB -> [ incdir "packages" ] + UserPackageDB -> [] --TODO any standard per-user db? + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let cabalFile = pkgdir <.> "cabal" + cabalExists <- doesFileExist cabalFile + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | cabalExists -> getPhonyInstalledPackageInfo pkgname cabalFile + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of nhc98 which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the .cabal file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the .cabal file, looking for a line like: + -- + -- > version: 2.0 + -- + extractVersion :: String -> Maybe Version + extractVersion content = + case catMaybes (map extractVersionLine (lines content)) of + [version] -> Just version + _ -> Nothing + extractVersionLine :: String -> Maybe Version + extractVersionLine line = + case words line of + [versionTag, ":", versionStr] + | map toLower versionTag == "version" -> simpleParse versionStr + [versionTag, versionStr] + | map toLower versionTag == "version:" -> simpleParse versionStr + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo -- ----------------------------------------------------------------------------- -- Building diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs --- a/Distribution/Simple/PackageIndex.hs +++ b/Distribution/Simple/PackageIndex.hs @@ -445,7 +445,7 @@ dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed (completed, _) -> Right (brokenPackages completed) - where + where closure completed failed [] = (completed, failed) closure completed failed (pkgid:pkgids) = case lookupInstalledPackageId index pkgid of Nothing -> closure completed (pkgid:failed) pkgids diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -59,7 +59,6 @@ import Distribution.Simple.PreProcess.Unlit (unlit) import Distribution.Package ( Package(..), PackageName(..) ) -import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..), withExe @@ -84,8 +83,6 @@ ( OS(OSX, Windows), buildOS ) import Distribution.Version (Version(..)) import Distribution.Verbosity -import Distribution.Text - ( display ) import Control.Monad (when, unless) import Data.Maybe (fromMaybe) @@ -182,8 +179,9 @@ setupMessage verbosity "Preprocessing library" (packageId pkg_descr) let bi = libBuildInfo lib let biHandlers = localHandlers bi - sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist - modu verbosity builtinSuffixes biHandlers + sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist + (ModuleName.toFilePath modu) verbosity + builtinSuffixes biHandlers | modu <- libModules lib ] unless (null (executables pkg_descr)) $ setupMessage verbosity "Preprocessing executables for" (packageId pkg_descr) @@ -191,12 +189,12 @@ let bi = buildInfo theExe let biHandlers = localHandlers bi let exeDir = buildDir lbi exeName theExe exeName theExe ++ "-tmp" - sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist - modu verbosity builtinSuffixes biHandlers + sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist + (ModuleName.toFilePath modu) verbosity + builtinSuffixes biHandlers | modu <- otherModules bi] - preprocessModule (hsSourceDirs bi) exeDir forSDist - --FIXME: we should not pretend it's a module name: - (ModuleName.simple (dropExtensions (modulePath theExe))) + preprocessFile (hsSourceDirs bi) exeDir forSDist + (dropExtensions (modulePath theExe)) verbosity builtinSuffixes biHandlers where hc = compilerFlavor (compiler lbi) builtinSuffixes @@ -206,27 +204,25 @@ -- |Find the first extension of the file that exists, and preprocess it -- if required. -preprocessModule +preprocessFile :: [FilePath] -- ^source directories -> FilePath -- ^build directory -> Bool -- ^preprocess for sdist - -> ModuleName -- ^module name + -> FilePath -- ^module file name -> Verbosity -- ^verbosity -> [String] -- ^builtin suffixes -> [(String, PreProcessor)] -- ^possible preprocessors -> IO () -preprocessModule searchLoc buildLoc forSDist modu verbosity builtinSuffixes handlers = do +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do -- look for files in the various source dirs with this module name -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc - (ModuleName.toFilePath modu) + psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile case psrcFiles of -- no preprocessor file exists, look for an ordinary source file Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc - (ModuleName.toFilePath modu) + bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc baseFile case bsrcFiles of - Nothing -> die $ "can't find source for " ++ display modu + Nothing -> die $ "can't find source for " ++ baseFile ++ " in " ++ intercalate ", " searchLoc _ -> return () -- found a pre-processable file in one of the source dirs @@ -243,11 +239,11 @@ -- platform independent files and put them into the 'buildLoc' -- (which we assume is set to the temp. directory that will become -- the tarball). + --TODO: eliminate sdist variant, just supply different handlers when (not forSDist || forSDist && platformIndependent pp) $ do -- look for existing pre-processed source file in the dest dir to -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] - (ModuleName.toFilePath modu) + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile recomp <- case ppsrcFiles of Nothing -> return True Just ppsrcFile -> do @@ -261,9 +257,9 @@ (psrcLoc, psrcRelFile) (buildLoc, srcStem <.> "hs") verbosity - where dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x + where dirName = takeDirectory + tailNotNull [] = [] + tailNotNull x = tail x -- ------------------------------------------------------------ -- * known preprocessors diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -71,13 +71,18 @@ import qualified Distribution.Simple.GHC as GHC import Distribution.Simple.Compiler ( compilerVersion, CompilerFlavor(..), compilerFlavor - , PackageDB(..), registrationPackageDB ) + , PackageDB(..), PackageDBStack, registrationPackageDB ) import Distribution.Simple.Program - ( ConfiguredProgram, runProgramInvocation + ( ConfiguredProgram , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) import Distribution.Simple.Program.Script ( invocationAsSystemScript ) import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Program.Run + ( ProgramInvocation(..), IOEncoding(..), programInvocation + , runProgramInvocation ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram(programId, programVersion) ) import Distribution.Simple.Setup ( RegisterFlags(..), CopyDest(..) , fromFlag, fromFlagOrDefault, flagToMaybe ) @@ -98,7 +103,7 @@ ( display ) import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) + ( Verbosity, normal, deafening, silent ) import Distribution.Compat.CopyFile ( setFileExecutable ) @@ -109,7 +114,7 @@ import Control.Monad (when) import Data.Maybe - ( isJust, fromMaybe ) + ( isJust, fromMaybe, maybeToList ) import Data.List (partition) @@ -130,8 +135,8 @@ case () of _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> writeRegisterScript installedPkgInfo - | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace packageDb + | otherwise -> registerPackage' verbosity + installedPkgInfo pkg lbi inplace packageDbs where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) @@ -141,8 +146,8 @@ modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) + packageDbs = withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) @@ -153,9 +158,9 @@ writeRegisterScript installedPkgInfo = case compilerFlavor (compiler lbi) of GHC -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi) - writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDb + writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs LHC -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi) - writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDb + writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs Hugs -> notice verbosity "Registration scripts not needed for hugs" JHC -> notice verbosity "Registration scripts not needed for jhc" NHC -> notice verbosity "Registration scripts not needed for nhc98" @@ -205,12 +210,27 @@ -> Bool -> PackageDB -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace packageDb = do +registerPackage verbosity installedPkgInfo pkg lbi inplace packageDb = + registerPackage' verbosity installedPkgInfo pkg lbi inplace packageDbs + where + packageDbs + | registrationPackageDB (withPackageDB lbi) == packageDb + = withPackageDB lbi + | otherwise = withPackageDB lbi ++ [packageDb] + +registerPackage' :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage' verbosity installedPkgInfo pkg lbi inplace packageDbs = do setupMessage verbosity "Registering" (packageId pkg) case compilerFlavor (compiler lbi) of - GHC -> registerPackageGHC verbosity installedPkgInfo pkg lbi inplace packageDb - LHC -> registerPackageLHC verbosity installedPkgInfo pkg lbi inplace packageDb - Hugs -> registerPackageHugs verbosity installedPkgInfo pkg lbi inplace packageDb + GHC -> registerPackageGHC verbosity installedPkgInfo pkg lbi inplace packageDbs + LHC -> registerPackageLHC verbosity installedPkgInfo pkg lbi inplace packageDbs + Hugs -> registerPackageHugs verbosity installedPkgInfo pkg lbi inplace packageDbs JHC -> notice verbosity "Registering for jhc (nothing to do)" NHC -> notice verbosity "Registering for nhc98 (nothing to do)" _ -> die "Registering is not implemented for this compiler" @@ -222,17 +242,17 @@ -> PackageDescription -> LocalBuildInfo -> Bool - -> PackageDB + -> PackageDBStack -> IO () -registerPackageGHC verbosity installedPkgInfo _pkg lbi _inplace packageDb = do +registerPackageGHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) - HcPkg.reregister verbosity ghcPkg packageDb (Right installedPkgInfo) + reregister verbosity ghcPkg packageDbs installedPkgInfo -registerPackageLHC verbosity installedPkgInfo _pkg lbi _inplace packageDb = do +registerPackageLHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) - HcPkg.reregister verbosity lhcPkg packageDb (Right installedPkgInfo) + reregister verbosity lhcPkg packageDbs installedPkgInfo -registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDb = do +registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDbs = do when inplace $ die "--inplace is not supported with Hugs" let installDirs = absoluteInstallDirs pkg lbi NoCopyDest createDirectoryIfMissingVerbose verbosity True (libdir installDirs) @@ -243,11 +263,11 @@ writeHcPkgRegisterScript :: Verbosity -> InstalledPackageInfo -> ConfiguredProgram - -> PackageDB + -> PackageDBStack -> IO () -writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDb = do - let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal - packageDb (Right installedPkgInfo) +writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do + let invocation = reregisterInvocation hcPkg Verbosity.normal + packageDbs installedPkgInfo regScript = invocationAsSystemScript buildOS invocation notice verbosity ("Creating package registration script: " ++ regScriptFileName) @@ -403,3 +423,48 @@ unregScriptFileName = case buildOS of Windows -> "unregister.bat" _ -> "unregister.sh" + +reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack + -> InstalledPackageInfo + -> IO () +reregister verbosity hcPkg packagedb pkgFile = + runProgramInvocation verbosity + (reregisterInvocation hcPkg verbosity packagedb pkgFile) + +reregisterInvocation :: ConfiguredProgram -> Verbosity -> PackageDBStack + -> InstalledPackageInfo + -> ProgramInvocation +reregisterInvocation hcPkg verbosity packagedbs pkgInfo = + (programInvocation hcPkg args) { + progInvokeInput = Just (showInstalledPackageInfo pkgInfo), + progInvokeInputEncoding = IOEncodingUTF8 + } + where + args = ["update", "-"] ++ packageDbStackOpts packagedbs + ++ verbosityOpts verbosity + + verbosityOpts :: Verbosity -> [String] + verbosityOpts v + + -- ghc-pkg < 6.11 does not support -v + | programId hcPkg == "ghc-pkg" + && programVersion hcPkg < Just (Version [6,11] []) + = [] + + | v >= deafening = ["-v2"] + | v == silent = ["-v0"] + | otherwise = [] + + packageDbStackOpts :: PackageDBStack -> [String] + packageDbStackOpts dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : "--no-user-package-conf" + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--package-conf=" ++ db + specific _ = ierror + ierror = error "internal error: unexpected package db stack" diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -161,7 +161,7 @@ , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error ( isDoesNotExistError, ioeSetFileName, ioeGetFileName, ioeGetErrorString ) -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 608) +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) import System.IO.Error ( ioeSetLocation, ioeGetLocation ) #endif @@ -220,7 +220,7 @@ . flip ioeSetFileName (normalise filename) $ userError msg where -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 608) +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) setLocation _ err = err #else setLocation Nothing err = err @@ -243,7 +243,7 @@ file = case ioeGetFileName ioe of Nothing -> "" Just path -> path ++ location ++ ": " -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 608) +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) location = "" #else location = case ioeGetLocation ioe of diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,14 @@ -*-change-log-*- +1.8.0.4 Duncan Coutts March 2010 + * Fix exe-depends-on-lib feature with ghc-6.12 + * Fix use of --package-db with ghc-6.12 + * By default $datadir now follows the $prefix on Windows + * Find ar.exe on windows better + * Fix mixup between $arch and $os path variables + * Support for for hugs and nhc package databases + * Set dynlib name for shared libs on OSX + 1.8.0.2 Duncan Coutts December 2009 * Support for GHC-6.12 * New unique installed package IDs which use a package hash