diff --git a/plugins.cabal b/plugins.cabal index 05f4320..a1a8af1 100644 --- a/plugins.cabal +++ b/plugins.cabal @@ -41,13 +41,14 @@ library 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 index 1b0a9f7..f071ce6 100644 --- a/src/System/MkTemp.hs +++ b/src/System/MkTemp.hs @@ -48,9 +48,7 @@ import System.IO.Error ( isAlreadyExistsError ) 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 @@ tweak i s -- --------------------------------------------------------------------- -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 index cfd6434..2c63b59 100644 --- a/src/System/Plugins/Env.hs +++ b/src/System/Plugins/Env.hs @@ -52,11 +52,6 @@ module System.Plugins.Env ( 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 Data.IORef ( writeIORef, readIORef, newIORef, IORef() ) @@ -74,8 +69,14 @@ import System.IO.Error ( catch, ioError, isDoesNotExistError ) 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 @@ type Env = (MVar (), 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 @@ addPkgConf f = do 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,9 +311,14 @@ grabDefaultPkgConf = do -- readPackageConf :: FilePath -> IO [PackageConfig] readPackageConf f = do - s <- readFile f - let p = parsePkgConf s - return $! map expand_libdir p +-- s <- readFile f +-- let p = map parseInstalledPackageInfo $ splitPkgs s +-- return $ flip map p $ \p' -> case p' of +-- ParseFailed e -> error $ show e +-- ParseOk _ c -> expand_libdir c + pc <- configureAllKnownPrograms silent defaultProgramConfiguration + pkgIndex <- getInstalledPackages silent (SpecificPackageDB f) pc + return $ allPackages pkgIndex where expand_libdir :: PackageConfig -> PackageConfig @@ -324,6 +331,15 @@ readPackageConf f = do expand s | "$libdir" `isPrefixOf` s = ghcLibraryPath ++ drop 7 s expand s = s + splitPkgs :: String -> [String] + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + -- ----------------------------------------------------------- -- Static package management stuff. A static package is linked with the base -- application and we should therefore not link with any of the DLLs it requires. @@ -332,10 +348,7 @@ addStaticPkg :: PackageName -> IO () 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 +418,21 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p 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 +467,10 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p 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 index d0e9a0f..9b6ebaa 100644 --- a/src/System/Plugins/Load.hs +++ b/src/System/Plugins/Load.hs @@ -69,8 +69,7 @@ import System.Plugins.LoadTypes -- 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' :: FilePath -> IO ModIface 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 index 8617271..ae4bdf3 100644 --- a/src/System/Plugins/Make.hs +++ b/src/System/Plugins/Make.hs @@ -75,7 +75,6 @@ import System.Directory ( doesFileExist, removeFile , getModificationTime ) import Control.Exception ( handleJust ) -import GHC.IOBase ( Exception(IOException) ) #if __GLASGOW_HASKELL__ >= 604 import System.IO.Error ( isDoesNotExistError ) @@ -148,7 +147,7 @@ make src args = rawMake src ("-c":args) True -- 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 @@ build src obj extra_opts = do -- 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 @@ makeCleaner f = makeClean f >> rm_f (dropSuffix f <> hsSuf) -- 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 index 6d4df5c..bb6d31b 100644 --- a/src/System/Plugins/PackageAPI.hs +++ b/src/System/Plugins/PackageAPI.hs @@ -40,7 +40,8 @@ module System.Plugins.PackageAPI ( #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 PackageName = String 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 }