diff --git a/plugins.cabal b/plugins.cabal --- a/plugins.cabal +++ b/plugins.cabal @@ -1,5 +1,5 @@ name: plugins -version: 1.3.1 +version: 1.4.0 homepage: http://code.haskell.org/~dons/code/hs-plugins synopsis: Dynamic linking for Haskell and C objects description: Dynamic linking and runtime evaluation of Haskell, @@ -12,7 +12,7 @@ License-file: LICENSE author: Don Stewart 2004-2008 maintainer: Don Stewart -cabal-version: >= 1.2 +cabal-version: >= 1.6 build-type: Configure extra-source-files: config.guess, config.h.in, config.mk.in, config.sub, configure, configure.ac, install.sh, Makefile, @@ -33,7 +33,6 @@ System.Plugins.Make, System.Plugins.Package, System.Plugins.PackageAPI, - System.Plugins.ParsePkgConfCabal, System.Plugins.Parser, System.Plugins.Process, System.Plugins.Utils @@ -41,13 +40,14 @@ extensions: CPP, ForeignFunctionInterface ghc-options: -Wall -funbox-strict-fields -fno-warn-missing-signatures hs-source-dirs: src - build-depends: base >= 3 && < 4, - Cabal >= 1.4 && < 1.5, + build-depends: base >= 4, + Cabal >= 1.6, haskell-src, containers, array, directory, random, process, - ghc >= 6.8 + ghc >= 6.10, + ghc-prim diff --git a/src/System/MkTemp.hs b/src/System/MkTemp.hs --- a/src/System/MkTemp.hs +++ b/src/System/MkTemp.hs @@ -48,9 +48,7 @@ import System.IO.Error ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError ) #endif -import GHC.IOBase ( IOException(IOError), - Exception(IOException), - IOErrorType(AlreadyExists) ) +import GHC.IOBase (IOException(..), IOErrorType(AlreadyExists) ) #ifndef __MINGW32__ import qualified System.Posix.Internals ( c_getpid ) @@ -185,20 +183,18 @@ -- --------------------------------------------------------------------- -alreadyExists :: Exception -> Maybe Exception -alreadyExists e@(IOException ioe) - | isAlreadyExistsError ioe = Just e +alreadyExists :: IOError -> Maybe IOError +alreadyExists ioe + | isAlreadyExistsError ioe = Just ioe | otherwise = Nothing -alreadyExists _ = Nothing -isInUse :: Exception -> Maybe () +isInUse :: IOError -> Maybe () #ifndef __MINGW32__ -isInUse (IOException ioe) +isInUse ioe | isAlreadyExistsError ioe = Just () | otherwise = Nothing -isInUse _ = Nothing #else -isInUse (IOException ioe) +isInUse ioe | isAlreadyInUseError ioe = Just () | isPermissionError ioe = Just () | isAlreadyExistsError ioe = Just () -- we throw this diff --git a/src/System/Plugins/Env.hs b/src/System/Plugins/Env.hs --- a/src/System/Plugins/Env.hs +++ b/src/System/Plugins/Env.hs @@ -52,16 +52,11 @@ import System.Plugins.LoadTypes (Module) import System.Plugins.PackageAPI {- everything -} -#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 -import System.Plugins.ParsePkgConfCabal( parsePkgConf ) -#else -import System.Plugins.ParsePkgConfLite ( parsePkgConf ) -#endif -import System.Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix ) +import System.Plugins.Consts ( sysPkgConf, sysPkgSuffix ) import Data.IORef ( writeIORef, readIORef, newIORef, IORef() ) import Data.Maybe ( isJust, isNothing, fromMaybe ) -import Data.List ( isPrefixOf, isInfixOf, nub ) +import Data.List ( isInfixOf, nub ) import System.IO.Unsafe ( unsafePerformIO ) import System.IO ( hGetContents ) @@ -74,8 +69,14 @@ import Control.Concurrent.MVar ( MVar(), newMVar, withMVar ) -import Distribution.Package hiding (packageName) -import Text.ParserCombinators.ReadP +import Distribution.InstalledPackageInfo +-- import Distribution.Package hiding (packageName, PackageName(..)) +import Distribution.Simple.Compiler +import Distribution.Simple.GHC +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Text +import Distribution.Verbosity import qualified Data.Map as M import qualified Data.Set as S @@ -147,6 +148,7 @@ IORef StaticPkgEnv, IORef MergeEnv) + -- -- our environment, contains a set of loaded objects, and a map of known -- packages and their informations. Initially all we know is the default @@ -285,9 +287,9 @@ union :: PkgEnvs -> [PackageConfig] -> PkgEnvs union ls ps' = let fm = emptyFM -- new FM for this package.conf - in foldr (\p fm' -> if packageName_ p == "base" -- ghc doesn't supply a version with 'base' - -- for some reason. - then addToFM (addToFM fm' (packageName_ p) p) (packageName p) p + in foldr (\p fm' -> if (display $ package p) == "base" -- ghc doesn't supply a version with 'base' + -- for some reason. + then addToFM (addToFM fm' (display $ package p) p) (packageName p) p else addToFM fm' (packageName p) p) fm ps' : ls -- @@ -309,20 +311,9 @@ -- readPackageConf :: FilePath -> IO [PackageConfig] readPackageConf f = do - s <- readFile f - let p = parsePkgConf s - return $! map expand_libdir p - - where - expand_libdir :: PackageConfig -> PackageConfig - expand_libdir pk = - let pk' = updImportDirs (\idirs -> map expand idirs) pk - pk'' = updLibraryDirs (\ldirs -> map expand ldirs) pk' - in pk'' - - expand :: FilePath -> FilePath - expand s | "$libdir" `isPrefixOf` s = ghcLibraryPath ++ drop 7 s - expand s = s + pc <- configureAllKnownPrograms silent defaultProgramConfiguration + pkgIndex <- getInstalledPackages silent (SpecificPackageDB f) pc + return $ allPackages pkgIndex -- ----------------------------------------------------------- -- Static package management stuff. A static package is linked with the base @@ -332,10 +323,7 @@ addStaticPkg pkg = modifyStaticPkgEnv env $ \set -> return $ S.insert pkg set isStaticPkg :: PackageName -> IO Bool -isStaticPkg pkg - = case readP_to_S parsePackageName pkg of - ((pkgName,_):_) -> withStaticPkgEnv env $ \set -> return $ S.member pkgName set - [] -> return False +isStaticPkg pkg = withStaticPkgEnv env $ \set -> return $ S.member pkg set -- -- Package path, given a package name, look it up in the environment and @@ -405,21 +393,21 @@ go (fm:fms) q = case lookupFM fm q of Nothing -> go fms q -- look in other pkgs - Just package -> do - let hslibs = hsLibraries package - extras' = extraLibraries package + Just pkg -> do + let hslibs = hsLibraries pkg + extras' = extraLibraries pkg cbits = filter (\e -> reverse (take (length "_cbits") (reverse e)) == "_cbits") extras' extras = filter (flip notElem cbits) extras' - ldopts = ldOptions package - deppkgs = packageDeps package + ldopts = ldOptions pkg + deppkgs = packageDeps pkg ldInput <- mapM classifyLdInput ldopts let ldOptsLibs = [ path | Just (DLL path) <- ldInput ] ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ] dlls = map mkSOName (extras ++ ldOptsLibs) #if defined(CYGWIN) || defined(__MINGW32__) - libdirs = fix_topdir (libraryDirs package) ++ ldOptsPaths + libdirs = fix_topdir (libraryDirs pkg) ++ ldOptsPaths #else - libdirs = libraryDirs package ++ ldOptsPaths + libdirs = libraryDirs pkg ++ ldOptsPaths #endif -- If we're loading dynamic libs we need the cbits to appear before the -- real packages. @@ -454,10 +442,10 @@ replace_topdir (x:xs) = x : replace_topdir xs #endif -- a list elimination form for the Maybe type - filterRight :: [Either left right] -> [right] - filterRight [] = [] - filterRight (Right x:xs) = x:filterRight xs - filterRight (Left _:xs) = filterRight xs + --filterRight :: [Either left right] -> [right] + --filterRight [] = [] + --filterRight (Right x:xs) = x:filterRight xs + --filterRight (Left _:xs) = filterRight xs -- -- Check that a path to a library actually reaches a library diff --git a/src/System/Plugins/Load.hs b/src/System/Plugins/Load.hs --- a/src/System/Plugins/Load.hs +++ b/src/System/Plugins/Load.hs @@ -69,8 +69,7 @@ -- import Language.Hi.Parser import BinIface import HscTypes -import Module (moduleName, moduleNameString) -import PackageConfig (packageIdString) +import Module (moduleName, moduleNameString, packageIdString) import HscMain (newHscEnv) import TcRnMonad (initTcRnIf) @@ -97,7 +96,7 @@ readBinIface' hi_path = do -- kludgy as hell e <- newHscEnv undefined - initTcRnIf 'r' e undefined undefined (readBinIface hi_path) + initTcRnIf 'r' e undefined undefined (readBinIface IgnoreHiWay QuietBinIFaceReading hi_path) -- TODO need a loadPackage p package.conf :: IO () primitive diff --git a/src/System/Plugins/Make.hs b/src/System/Plugins/Make.hs --- a/src/System/Plugins/Make.hs +++ b/src/System/Plugins/Make.hs @@ -75,7 +75,6 @@ , getModificationTime ) import Control.Exception ( handleJust ) -import GHC.IOBase ( Exception(IOException) ) #if __GLASGOW_HASKELL__ >= 604 import System.IO.Error ( isDoesNotExistError ) @@ -148,7 +147,7 @@ -- makeAll :: FilePath -> [Arg] -> IO MakeStatus makeAll src args = - rawMake src ( "--make":"-no-hs-main":"-no-link":"-v0":args ) False + rawMake src ( "--make":"-no-hs-main":"-c":"-v0":args ) False -- | This is a variety of 'make' that first calls 'merge' to -- combine the plugin source with a syntax stub. The result is then @@ -295,7 +294,7 @@ -- does this work in the presence of hier plugins? -- won't handle hier names properly. - let ghc_opts = [ "-Onot" ] + let ghc_opts = [ "-O0" ] output = [ "-o", obj, "-odir", odir, "-hidir", odir, "-i" ++ odir ] @@ -436,10 +435,9 @@ -- rm_f f = handleJust doesntExist (\_->return ()) (removeFile f) where - doesntExist (IOException ioe) + doesntExist ioe | isDoesNotExistError ioe = Just () | otherwise = Nothing - doesntExist _ = Nothing readFile' f = do h <- openFile f ReadMode diff --git a/src/System/Plugins/PackageAPI.hs b/src/System/Plugins/PackageAPI.hs --- a/src/System/Plugins/PackageAPI.hs +++ b/src/System/Plugins/PackageAPI.hs @@ -40,7 +40,8 @@ #if CABAL == 1 || __GLASGOW_HASKELL__ >= 604 import Distribution.InstalledPackageInfo -import Distribution.Package hiding (depends, packageName) +import Distribution.Package hiding (depends, packageName, PackageName(..)) +import Distribution.Text #else import System.Plugins.Package #endif @@ -57,9 +58,9 @@ type PackageConfig = InstalledPackageInfo -packageName = showPackageId . package +packageName = display . package packageName_ = pkgName . package -packageDeps = (map showPackageId) . depends +packageDeps = (map display) . depends updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) = pk { importDirs = f idirs } diff --git a/src/System/Plugins/Process.hs b/src/System/Plugins/Process.hs --- a/src/System/Plugins/Process.hs +++ b/src/System/Plugins/Process.hs @@ -14,7 +14,7 @@ import qualified Posix as P #endif -import qualified Control.Exception +import qualified Control.OldException as E -- -- slight wrapper over popen for calls that don't care about stdin to the program @@ -38,7 +38,7 @@ -- popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ProcessID) popen file args minput = - Control.Exception.handle (\e -> return ([],show e,error (show e))) $ do + E.handle (\e -> return ([],show e, error (show e))) $ do (inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing @@ -55,8 +55,8 @@ -- data gets pulled as it becomes available. you have to force the -- output strings before waiting for the process to terminate. -- - forkIO (Control.Exception.evaluate (length output) >> return ()) - forkIO (Control.Exception.evaluate (length errput) >> return ()) + forkIO (E.evaluate (length output) >> return ()) + forkIO (E.evaluate (length errput) >> return ()) -- And now we wait. We must wait after we read, unsurprisingly. exitCode <- waitForProcess pid -- blocks without -threaded, you're warned. @@ -79,7 +79,7 @@ -- popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID) popen f s m = - Control.Exception.handle (\e -> return ([], show e, error $ show e )) $ do + E.handle (\e -> return ([], show e, error $ show e )) $ do x@(_,_,pid) <- P.popen f s m b <- P.getProcessStatus True False pid -- wait return $ case b of