Index: Distribution/Make.hs =================================================================== --- Distribution/Make.hs (revision 3892) +++ Distribution/Make.hs (revision 3893) @@ -129,7 +129,7 @@ maybe "" (" prefix="++) mprefix InstallCmd uInst -> do - ((_,_), _, args) <- parseInstallArgs (uInst,0) args [] + ((_,_,_), _, args) <- parseInstallArgs (uInst,Nothing,0) args [] no_extra_flags args maybeExit $ system $ "make install" retVal <- exec "make register" @@ -159,10 +159,10 @@ SDistCmd -> basicCommand "SDist" "make dist" (parseSDistArgs args []) RegisterCmd uInst genScript -> basicCommand "Register" "make register" - (parseRegisterArgs (uInst,genScript, 0) args []) + (parseRegisterArgs (uInst, Nothing, genScript, 0) args []) UnregisterCmd uInst genScript -> basicCommand "Unregister" "make unregister" - (parseUnregisterArgs (uInst, genScript, 0) args []) + (parseUnregisterArgs (uInst, Nothing, genScript, 0) args []) ProgramaticaCmd -> basicCommand "Programatica" "make programatica" (parseProgramaticaArgs args []) Index: Distribution/Simple/Install.hs =================================================================== --- Distribution/Simple/Install.hs (revision 3892) +++ Distribution/Simple/Install.hs (revision 3893) @@ -71,7 +71,7 @@ import Distribution.Compiler (CompilerFlavor(..), Compiler(..), showCompilerId) import Control.Monad(when) -import Data.Maybe(fromMaybe) +import Data.Maybe(fromMaybe,fromJust) import Distribution.Compat.Directory(createDirectoryIfMissing, removeDirectoryRecursive, findExecutable) import Distribution.Compat.FilePath(joinFileName, dllExtension, exeExtension, @@ -95,7 +95,9 @@ let binPref = mkBinDir pkg_descr lbi install_prefixM setupMessage ("Installing: " ++ libPref ++ " & " ++ binPref) pkg_descr case compilerFlavor (compiler lbi) of - GHC -> do when (hasLibs pkg_descr) (installLibGHC verbose (withProfLib lbi) libPref buildPref pkg_descr) + GHC -> do when (hasLibs pkg_descr) $ do + installLibGHC verbose (withProfLib lbi) libPref buildPref pkg_descr + installIncludes verbose libPref buildPref pkg_descr installExeGhc verbose binPref buildPref pkg_descr Hugs -> installHugs verbose libPref binPref targetLibPref buildPref pkg_descr _ -> die ("only installing with GHC or Hugs is implemented") @@ -146,6 +148,40 @@ installLibGHC _ _ _ _ PackageDescription{library=Nothing} = die $ "Internal Error. installLibGHC called with no library." + +installIncludes :: Int -- ^verbose + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> PackageDescription + -> IO () +installIncludes verbose pref buildPref pkg_descr + | null local_incs = return () -- no package-local include files. + | otherwise = do + -- create the package include directories off of the + -- installation (lib) directory. + mapM_ (\ fp -> createDirectoryIfMissing True (dest_dir ` joinFileName` fp)) + local_dirs + -- Note: local package directories used in the local header files in + -- the Include: field must be given in the Include-Dirs: field. + mapM_ (\ fp -> copyFileVerbose verbose fp (dest_dir `joinFileName` fp)) local_incs + return () + where + lib = fromJust (library pkg_descr) -- checked for Nothing earlier. + bi = libBuildInfo lib + + dest_dir = pref + + incs = includes bi + dirs = includeDirs bi + + local_dirs = filter isLocal dirs + local_incs = filter isLocal incs + + -- extremely simplistic test for package-local include files + isLocal ('/':_) = False + isLocal ('+':_) = False + isLocal _ = True + -- Install for Hugs -- For install, copy-prefix = prefix, but for copy they're different. -- The library goes in /lib/hugs/packages/ Index: Distribution/Simple/LocalBuildInfo.hs =================================================================== --- Distribution/Simple/LocalBuildInfo.hs (revision 3892) +++ Distribution/Simple/LocalBuildInfo.hs (revision 3893) @@ -68,6 +68,7 @@ withC2hs :: Maybe FilePath, -- ^Might be the location of the C2hs executable. withCpphs :: Maybe FilePath, -- ^Might be the location of the Cpphs executable. withGreencard :: Maybe FilePath, -- ^Might be the location of the GreenCard executable. + withGhcPkgConf :: Maybe FilePath, withProfLib :: Bool, withProfExe :: Bool } Index: Distribution/Simple/Build.hs =================================================================== --- Distribution/Simple/Build.hs (revision 3892) +++ Distribution/Simple/Build.hs (revision 3893) @@ -131,8 +131,9 @@ let pref = buildDir lbi let ghcPath = compilerPath (compiler lbi) ifProfLib = when (withProfLib lbi) - pkgConf <- GHC.localPackageConfig - pkgConfReadable <- GHC.canReadLocalPackageConfig + mbPkgConf = withGhcPkgConf lbi + pkgConf <- GHC.localPackageConfig mbPkgConf + pkgConfReadable <- GHC.canReadLocalPackageConfig pkgConf -- Build lib withLib pkg_descr () $ \lib -> do let libBi = libBuildInfo lib Index: Distribution/Simple/Configure.hs =================================================================== --- Distribution/Simple/Configure.hs (revision 3892) +++ Distribution/Simple/Configure.hs (revision 3893) @@ -153,6 +153,7 @@ message $ "Compiler flavor: " ++ (show f') message $ "Compiler version: " ++ showVersion ver message $ "Using package tool: " ++ pkg + message $ "Using package file: " ++ (case configGHCPkgFile cfg of { Nothing -> "default user/system" ; Just f -> f }) reportProgram "haddock" haddock reportProgram "happy" happy reportProgram "alex" alex @@ -173,6 +174,7 @@ withHsc2hs=hsc2hs, withC2hs=c2hs, withCpphs=cpphs, withGreencard=greencard, + withGhcPkgConf=configGHCPkgFile cfg, withProfLib=configProfLib cfg, withProfExe=configProfExe cfg } Index: Distribution/Simple/GHCPackageConfig.hs =================================================================== --- Distribution/Simple/GHCPackageConfig.hs (revision 3892) +++ Distribution/Simple/GHCPackageConfig.hs (revision 3893) @@ -31,44 +31,47 @@ import IO (try) #endif import Control.Monad(unless) +import Data.Maybe(fromJust) import Text.PrettyPrint.HughesPJ import System.Directory (doesFileExist, getPermissions, Permissions (..)) -import Distribution.Compat.FilePath (joinFileName) +import Distribution.Compat.FilePath (joinFileName, splitFileName) import Distribution.Compat.Directory (getHomeDirectory) -- |Where ghc keeps the --user files. -- |return the file, whether it exists, and whether it's readable -localPackageConfig :: IO FilePath -localPackageConfig = do u <- getHomeDirectory - return $ (u `joinFileName` ".ghc-packages") +localPackageConfig :: Maybe FilePath -> IO FilePath +localPackageConfig (Just f) = return f +localPackageConfig _ = do + u <- getHomeDirectory + return $ (u `joinFileName` ".ghc-packages") -- |If the package file doesn't exist, we should try to create it. If -- it already exists, do nothing and return true. This does not take -- into account whether it is readable or writeable. -maybeCreateLocalPackageConfig :: IO Bool -- ^success? -maybeCreateLocalPackageConfig - = do f <- localPackageConfig +maybeCreateLocalPackageConfig :: Maybe FilePath -> IO Bool -- ^success? +maybeCreateLocalPackageConfig mb + = do f <- localPackageConfig mb exists <- doesFileExist f unless exists $ (try (writeFile f "[]\n") >> return ()) doesFileExist f -- |Helper function for canReadPackageConfig and canWritePackageConfig -checkPermission :: (Permissions -> Bool) -> IO Bool -checkPermission perm - = do f <- localPackageConfig +checkPermission :: (Permissions -> Bool) -> FilePath -> IO Bool +checkPermission perm fp + = do f <- localPackageConfig (Just fp) exists <- doesFileExist f if exists then getPermissions f >>= (return . perm) else return False -- |Check for read permission on the localPackageConfig -canReadLocalPackageConfig :: IO Bool +canReadLocalPackageConfig :: FilePath -> IO Bool canReadLocalPackageConfig = checkPermission readable -- |Check for write permission on the localPackageConfig -canWriteLocalPackageConfig :: IO Bool +canWriteLocalPackageConfig :: FilePath -> IO Bool canWriteLocalPackageConfig = checkPermission writable -- ----------------------------------------------------------------------------- @@ -82,18 +85,46 @@ = defaultGHCPackageConfig { name = pkg_name, auto = False, - import_dirs = [mkLibDir pkg_descr lbi Nothing], - library_dirs = (mkLibDir pkg_descr lbi Nothing : + import_dirs = [lib_dir], + library_dirs = (lib_dir : maybe [] (extraLibDirs . libBuildInfo) (library pkg_descr)), hs_libraries = ["HS"++(showPackageId (package pkg_descr))], extra_libraries = maybe [] (extraLibs . libBuildInfo) (library pkg_descr), - include_dirs = maybe [] (includeDirs . libBuildInfo) (library pkg_descr), - c_includes = maybe [] (includes . libBuildInfo) (library pkg_descr), + include_dirs = (if hasLocalIncludes && null inc_dirs then (inc_dir:) else id) $ map expandLocalPath inc_dirs, + c_includes = map stripLocalPath $ maybe [] (includes . libBuildInfo) (library pkg_descr), package_deps = map pkgName (packageDeps lbi) } where pkg_name = pkgName (package pkg_descr) + bi = libBuildInfo (fromJust $ library pkg_descr) + -- sad cut-and-pasting of code from Distribution.Simple.Register.mkInstalledPackageInfo; + -- ToDo: better. + hasLocalIncludes = not $ null $ filter isLocal $ includes bi + + isLocal ('/':_) = False + isLocal _ = True + + inc_dirs = maybe [] (includeDirs . libBuildInfo) (library pkg_descr) + + lib_dir = mkLibDir pkg_descr lbi Nothing + inc_dir = lib_dir + + expandLocalPath p + | not $ isLocal p = p + | otherwise = lib_dir `joinFileName` p + + -- local Includes: entries have their package-local portion + -- of their filename chopped off (i.e., "foo/bar.h" gets + -- transformed to "bar.h"). The assumption here is that the + -- Include-Dirs: directory will contain "foo". + stripLocalPath p + | not $ isLocal p = p + | otherwise = + case p of + '+':xs -> xs + _ -> snd $ splitFileName p + data GHCPackageConfig = GHCPackage { name :: String, Index: Distribution/Simple/Register.hs =================================================================== --- Distribution/Simple/Register.hs (revision 3892) +++ Distribution/Simple/Register.hs (revision 3893) @@ -83,7 +83,7 @@ (createDirectoryIfMissing,removeDirectoryRecursive, setPermissions, getPermissions, Permissions(executable) ) -import Distribution.Compat.FilePath (joinFileName) +import Distribution.Compat.FilePath (joinFileName, splitFileName) import System.Directory(doesFileExist, removeFile) import System.IO.Error (try) @@ -119,7 +119,7 @@ register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () -register pkg_descr lbi (userInst, genScript, verbose) +register pkg_descr lbi (userInst, mbConfig, genScript, verbose) | isNothing (library pkg_descr) = do setupMessage "No package to register" pkg_descr return () @@ -134,12 +134,12 @@ config_flags <- if userInst - then if ghc_63_plus + then if ghc_63_plus && isNothing mbConfig then return ["--user"] else do - GHC.maybeCreateLocalPackageConfig - localConf <- GHC.localPackageConfig - pkgConfWriteable <- GHC.canWriteLocalPackageConfig + GHC.maybeCreateLocalPackageConfig mbConfig + localConf <- GHC.localPackageConfig mbConfig + pkgConfWriteable <- GHC.canWriteLocalPackageConfig localConf when (not pkgConfWriteable && not genScript) $ userPkgConfErr localConf return ["--config-file=" ++ localConf] @@ -223,6 +223,29 @@ = let lib = fromJust (library pkg_descr) -- checked for Nothing earlier bi = libBuildInfo lib + + hasLocalIncludes = not $ null $ filter isLocal $ includes bi + + isLocal ('/':_) = False + isLocal _ = True + + lib_dir = mkLibDir pkg_descr lbi Nothing + inc_dir = lib_dir + + expandLocalPath p + | not $ isLocal p = p + | otherwise = lib_dir `joinFileName` p + + -- local Includes: entries have their package-local portion + -- of their filename chopped off (i.e., "foo/bar.h" gets + -- transformed to "bar.h"). The assumption here is that the + -- Include-Dirs: directory will contain "foo". + stripLocalPath p + | not $ isLocal p = p + | otherwise = + case p of + '+':xs -> xs + _ -> snd $ splitFileName p in emptyInstalledPackageInfo{ IPI.package = package pkg_descr, @@ -238,12 +261,12 @@ IPI.exposed = True, IPI.exposedModules = exposedModules lib, IPI.hiddenModules = otherModules bi, - IPI.importDirs = [mkLibDir pkg_descr lbi Nothing], - IPI.libraryDirs = (mkLibDir pkg_descr lbi Nothing) : extraLibDirs bi, + IPI.importDirs = [lib_dir], + IPI.libraryDirs = lib_dir : extraLibDirs bi, IPI.hsLibraries = ["HS" ++ showPackageId (package pkg_descr)], IPI.extraLibraries = extraLibs bi, - IPI.includeDirs = includeDirs bi, - IPI.includes = includes bi, + IPI.includeDirs = (if hasLocalIncludes then (inc_dir:) else id) $ map expandLocalPath $ includeDirs bi, + IPI.includes = map stripLocalPath $ includes bi, IPI.depends = packageDeps lbi, IPI.hugsOptions = concat [opts | (Hugs,opts) <- options bi], IPI.ccOptions = ccOptions bi, @@ -258,7 +281,7 @@ -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () -unregister pkg_descr lbi (user_unreg, genScript, verbose) = do +unregister pkg_descr lbi (user_unreg, mbConfig, genScript, verbose) = do setupMessage "Unregistering" pkg_descr let ghc_63_plus = compilerVersion (compiler lbi) >= Version [6,3] [] let theName = pkgName (package pkg_descr) @@ -266,11 +289,11 @@ GHC -> do config_flags <- if user_unreg - then if ghc_63_plus + then if ghc_63_plus && isNothing mbConfig then return ["--user"] else do instConfExists <- doesFileExist installedPkgConfigFile - localConf <- GHC.localPackageConfig + localConf <- GHC.localPackageConfig mbConfig unless instConfExists (userPkgConfErr localConf) return ["--config-file=" ++ localConf] else return [] Index: Distribution/Simple.hs =================================================================== --- Distribution/Simple.hs (revision 3892) +++ Distribution/Simple.hs (revision 3893) @@ -92,7 +92,7 @@ import System.Directory(removeFile, doesFileExist) import Distribution.License -import Control.Monad(when, unless) +import Control.Monad(when, unless,mplus) import Data.List ( intersperse, unionBy ) import Data.Maybe ( isNothing, fromJust ) import System.IO.Error (try) @@ -264,12 +264,12 @@ postHook postCopy args flags localbuildinfo InstallCmd uInst -> do - (flags@(uInst, verbose), _, args) <- parseInstallArgs (uInst,0) args [] + (flags@(uInst, mbC, verbose), _, args) <- parseInstallArgs (uInst,Nothing,0) args [] pkg_descr <- hookOrInArgs preInst args flags localbuildinfo <- getPersistBuildConfig install pkg_descr localbuildinfo (Nothing, verbose) when (hasLibs pkg_descr) - (register pkg_descr localbuildinfo (uInst, False, verbose)) + (register pkg_descr localbuildinfo (uInst, mbC `mplus` withGhcPkgConf localbuildinfo, False, verbose)) postHook postInst args flags localbuildinfo SDistCmd -> do @@ -290,7 +290,7 @@ return out RegisterCmd uInst genScript -> do - (flags, _, args) <- parseRegisterArgs (uInst, genScript, 0) args [] + (flags, _, args) <- parseRegisterArgs (uInst, Nothing, genScript, 0) args [] pkg_descr <- hookOrInArgs preReg args flags localbuildinfo <- getPersistBuildConfig if hasLibs pkg_descr @@ -299,7 +299,7 @@ postHook postReg args flags localbuildinfo UnregisterCmd uInst genScript -> do - (flags,_, args) <- parseUnregisterArgs (uInst,genScript, 0) args [] + (flags,_, args) <- parseUnregisterArgs (uInst, Nothing, genScript, 0) args [] pkg_descr <- hookOrInArgs preUnreg args flags localbuildinfo <- getPersistBuildConfig unregister pkg_descr localbuildinfo flags @@ -492,9 +492,9 @@ preBuild = readHook id, preClean = readHook id, preCopy = readHook snd, - preInst = readHook snd, - preReg = readHook thd3, - preUnreg = readHook thd3 + preInst = readHook thd3, + preReg = readHook fth4, + preUnreg = readHook fth4 } where defaultPostConf :: Args -> ConfigFlags -> LocalBuildInfo -> IO ExitCode defaultPostConf args flags lbi @@ -520,7 +520,8 @@ putStrLn $ "Reading parameters from " ++ infoFile readHookedBuildInfo infoFile - thd3 (_,_,z) = z + thd3 (_,_,z) = z + fth4 (_,_,_,z) = z -- ------------------------------------------------------------ -- * Testing Index: Distribution/Setup.hs =================================================================== --- Distribution/Setup.hs (revision 3892) +++ Distribution/Setup.hs (revision 3893) @@ -106,7 +106,8 @@ configProfExe :: Bool, -- ^Enable profiling in the executables. configPrefix :: Maybe FilePath, -- ^installation prefix configVerbose :: Int, -- ^verbosity level - configUser :: Bool -- ^--user flag? + configUser :: Bool, -- ^--user flag? + configGHCPkgFile :: Maybe FilePath -- ^location of user config file } deriving (Show, Eq) @@ -126,7 +127,8 @@ configGreencard= Nothing, configPrefix = Nothing, configVerbose = 0, - configUser = False + configUser = False, + configGHCPkgFile = Nothing } -- |Most of these flags are for Configure, but InstPrefix is for Copy. @@ -135,6 +137,7 @@ | WithHaddock FilePath | WithHappy FilePath | WithAlex FilePath | WithHsc2hs FilePath | WithC2hs FilePath | WithCpphs FilePath | WithGreencard FilePath + | WithGhcPkgConfigFile FilePath | WithProfLib | WithoutProfLib | WithProfExe | WithoutProfExe -- For install, register, and unregister: @@ -269,6 +272,7 @@ "Disable executable profiling", Option "" ["user"] (NoArg UserFlag) "allow dependencies to be satisfied from the user package database", + ghc_pkg_opt, Option "" ["global"] (NoArg GlobalFlag) "(default) dependencies must be satisfied from the global package database" ], @@ -297,6 +301,7 @@ updateCfg t (Prefix path) = t { configPrefix = Just path } updateCfg t (Verbose n) = t { configVerbose = n } updateCfg t UserFlag = t { configUser = True } + updateCfg t (WithGhcPkgConfigFile f) = t { configGHCPkgFile=Just f } updateCfg t GlobalFlag = t { configUser = False } updateCfg t (Lift _) = t updateCfg t _ = error $ "Unexpected flag!" @@ -359,12 +364,17 @@ "[DEPRECATED, use copy]", Option "" ["user"] (NoArg UserFlag) "upon registration, register this package in the user's local package database", + ghc_pkg_opt, Option "" ["global"] (NoArg GlobalFlag) "(default) upon registration, register this package in the system-wide package database" ], cmdAction = InstallCmd False } +ghc_pkg_opt = + Option "" ["ghc-pkg-config-file"] (ReqArg WithGhcPkgConfigFile "PATH") + "path to user's ghc-pkg config file" + copyCmd :: Cmd a copyCmd = Cmd { cmdName = "copy", @@ -389,16 +399,17 @@ _ -> error $ "Unexpected flag!" -- | Flags to @install@: (user package, verbose) -type InstallFlags = (Bool,Int) +type InstallFlags = (Bool, Maybe FilePath, Int) parseInstallArgs :: InstallFlags -> [String] -> [OptDescr a] -> IO (InstallFlags, [a], [String]) parseInstallArgs = parseArgs installCmd updateCfg - where updateCfg (uFlag,verbose) fl = case fl of + where updateCfg (uFlag,mbF, verbose) fl = case fl of InstPrefix _ -> error "--install-prefix is obsolete. Use copy command instead." - UserFlag -> (True, verbose) - GlobalFlag -> (False, verbose) - Verbose n -> (uFlag, n) + UserFlag -> (True, mbF, verbose) + GlobalFlag -> (False, mbF, verbose) + Verbose n -> (uFlag, mbF, n) + WithGhcPkgConfigFile f -> (uFlag, Just f, verbose) _ -> error $ "Unexpected flag!" sdistCmd :: Cmd a @@ -446,22 +457,24 @@ Option "" ["global"] (NoArg GlobalFlag) "(default) upon registration, register this package in the system-wide package database", Option "" ["gen-script"] (NoArg GenScriptFlag) - "Instead of performing the register command, generate a script to register later" + "Instead of performing the register command, generate a script to register later", + ghc_pkg_opt ], cmdAction = RegisterCmd False False } -- | Flags to @register@ and @unregister@: (user package, gen-script, verbose) -type RegisterFlags = (Bool, Bool, Int) +type RegisterFlags = (Bool, Maybe FilePath, Bool, Int) parseRegisterArgs :: RegisterFlags -> [String] -> [OptDescr a] -> IO (RegisterFlags, [a], [String]) parseRegisterArgs = parseArgs registerCmd updateCfg - where updateCfg (uFlag, genScriptFlag, verbose) fl = case fl of - UserFlag -> (True, genScriptFlag, verbose) - GlobalFlag -> (False, genScriptFlag, verbose) - Verbose n -> (uFlag, genScriptFlag, n) - GenScriptFlag -> (uFlag, True, verbose) + where updateCfg (uFlag, mbF, genScriptFlag, verbose) fl = case fl of + UserFlag -> (True, mbF, genScriptFlag, verbose) + GlobalFlag -> (False, mbF, genScriptFlag, verbose) + Verbose n -> (uFlag, mbF, genScriptFlag, n) + WithGhcPkgConfigFile f -> (uFlag, Just f, genScriptFlag, verbose) + GenScriptFlag -> (uFlag, mbF, True, verbose) _ -> error $ "Unexpected flag!" unregisterCmd :: Cmd a @@ -475,8 +488,8 @@ Option "" ["global"] (NoArg GlobalFlag) "(default) unregister this package in the system-wide package database", Option "" ["gen-script"] (NoArg GenScriptFlag) - "Instead of performing the unregister command, generate a script to unregister later" - + "Instead of performing the unregister command, generate a script to unregister later", + ghc_pkg_opt ], cmdAction = UnregisterCmd False False } Index: tests/ModuleTest.hs =================================================================== --- tests/ModuleTest.hs (revision 3892) +++ tests/ModuleTest.hs (revision 3893) @@ -215,7 +215,7 @@ -- HUnit ,TestLabel ("testing the HUnit package" ++ compIdent) $ TestCase $ do setCurrentDirectory $ (testdir `joinFileName` "HUnit-1.0") - GHC.maybeCreateLocalPackageConfig + GHC.maybeCreateLocalPackageConfig Nothing system "make clean" system "make" assertCmd' compCmd "configure" "configure failed" @@ -245,7 +245,7 @@ doesDirectoryExist "dist/doc" >>= assertEqual "create of dist/doc" True assertBuild when (comp == GHC) -- tests building w/ an installed -package - (do pkgConf <- GHC.localPackageConfig + (do pkgConf <- GHC.localPackageConfig Nothing assertCmd' compCmd "install --user" "hunit install" assertCmd ("ghc -package-conf " ++ pkgConf ++ " -package HUnitTest HUnitTester.hs -o ./hunitTest")