Updating for GHC 6.10
This commit is contained in:
parent
80291eec13
commit
9d431c68a3
@ -41,13 +41,14 @@ library
|
|||||||
extensions: CPP, ForeignFunctionInterface
|
extensions: CPP, ForeignFunctionInterface
|
||||||
ghc-options: -Wall -funbox-strict-fields -fno-warn-missing-signatures
|
ghc-options: -Wall -funbox-strict-fields -fno-warn-missing-signatures
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
build-depends: base >= 3 && < 4,
|
build-depends: base >= 4,
|
||||||
Cabal >= 1.4 && < 1.5,
|
Cabal >= 1.6,
|
||||||
haskell-src,
|
haskell-src,
|
||||||
containers,
|
containers,
|
||||||
array,
|
array,
|
||||||
directory,
|
directory,
|
||||||
random,
|
random,
|
||||||
process,
|
process,
|
||||||
ghc >= 6.8
|
ghc >= 6.10,
|
||||||
|
ghc-prim
|
||||||
|
|
||||||
|
@ -48,9 +48,7 @@ import System.IO.Error ( isAlreadyExistsError )
|
|||||||
import System.IO.Error ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError )
|
import System.IO.Error ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError )
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
import GHC.IOBase ( IOException(IOError),
|
import GHC.IOBase (IOException(..), IOErrorType(AlreadyExists) )
|
||||||
Exception(IOException),
|
|
||||||
IOErrorType(AlreadyExists) )
|
|
||||||
|
|
||||||
#ifndef __MINGW32__
|
#ifndef __MINGW32__
|
||||||
import qualified System.Posix.Internals ( c_getpid )
|
import qualified System.Posix.Internals ( c_getpid )
|
||||||
@ -185,20 +183,18 @@ tweak i s
|
|||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
-- ---------------------------------------------------------------------
|
||||||
|
|
||||||
alreadyExists :: Exception -> Maybe Exception
|
alreadyExists :: IOError -> Maybe IOError
|
||||||
alreadyExists e@(IOException ioe)
|
alreadyExists ioe
|
||||||
| isAlreadyExistsError ioe = Just e
|
| isAlreadyExistsError ioe = Just ioe
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
alreadyExists _ = Nothing
|
|
||||||
|
|
||||||
isInUse :: Exception -> Maybe ()
|
isInUse :: IOError -> Maybe ()
|
||||||
#ifndef __MINGW32__
|
#ifndef __MINGW32__
|
||||||
isInUse (IOException ioe)
|
isInUse ioe
|
||||||
| isAlreadyExistsError ioe = Just ()
|
| isAlreadyExistsError ioe = Just ()
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
isInUse _ = Nothing
|
|
||||||
#else
|
#else
|
||||||
isInUse (IOException ioe)
|
isInUse ioe
|
||||||
| isAlreadyInUseError ioe = Just ()
|
| isAlreadyInUseError ioe = Just ()
|
||||||
| isPermissionError ioe = Just ()
|
| isPermissionError ioe = Just ()
|
||||||
| isAlreadyExistsError ioe = Just () -- we throw this
|
| isAlreadyExistsError ioe = Just () -- we throw this
|
||||||
|
@ -52,11 +52,6 @@ module System.Plugins.Env (
|
|||||||
|
|
||||||
import System.Plugins.LoadTypes (Module)
|
import System.Plugins.LoadTypes (Module)
|
||||||
import System.Plugins.PackageAPI {- everything -}
|
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 ( ghcLibraryPath, sysPkgConf, sysPkgSuffix )
|
||||||
|
|
||||||
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
|
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 Control.Concurrent.MVar ( MVar(), newMVar, withMVar )
|
||||||
|
|
||||||
import Distribution.Package hiding (packageName)
|
import Distribution.InstalledPackageInfo
|
||||||
import Text.ParserCombinators.ReadP
|
-- 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.Map as M
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
@ -147,6 +148,7 @@ type Env = (MVar (),
|
|||||||
IORef StaticPkgEnv,
|
IORef StaticPkgEnv,
|
||||||
IORef MergeEnv)
|
IORef MergeEnv)
|
||||||
|
|
||||||
|
|
||||||
--
|
--
|
||||||
-- our environment, contains a set of loaded objects, and a map of known
|
-- our environment, contains a set of loaded objects, and a map of known
|
||||||
-- packages and their informations. Initially all we know is the default
|
-- packages and their informations. Initially all we know is the default
|
||||||
@ -285,9 +287,9 @@ addPkgConf f = do
|
|||||||
union :: PkgEnvs -> [PackageConfig] -> PkgEnvs
|
union :: PkgEnvs -> [PackageConfig] -> PkgEnvs
|
||||||
union ls ps' =
|
union ls ps' =
|
||||||
let fm = emptyFM -- new FM for this package.conf
|
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'
|
in foldr (\p fm' -> if (display $ package p) == "base" -- ghc doesn't supply a version with 'base'
|
||||||
-- for some reason.
|
-- for some reason.
|
||||||
then addToFM (addToFM fm' (packageName_ p) p) (packageName p) p
|
then addToFM (addToFM fm' (display $ package p) p) (packageName p) p
|
||||||
else addToFM fm' (packageName p) p) fm ps' : ls
|
else addToFM fm' (packageName p) p) fm ps' : ls
|
||||||
|
|
||||||
--
|
--
|
||||||
@ -309,9 +311,14 @@ grabDefaultPkgConf = do
|
|||||||
--
|
--
|
||||||
readPackageConf :: FilePath -> IO [PackageConfig]
|
readPackageConf :: FilePath -> IO [PackageConfig]
|
||||||
readPackageConf f = do
|
readPackageConf f = do
|
||||||
s <- readFile f
|
-- s <- readFile f
|
||||||
let p = parsePkgConf s
|
-- let p = map parseInstalledPackageInfo $ splitPkgs s
|
||||||
return $! map expand_libdir p
|
-- 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
|
where
|
||||||
expand_libdir :: PackageConfig -> PackageConfig
|
expand_libdir :: PackageConfig -> PackageConfig
|
||||||
@ -324,6 +331,15 @@ readPackageConf f = do
|
|||||||
expand s | "$libdir" `isPrefixOf` s = ghcLibraryPath ++ drop 7 s
|
expand s | "$libdir" `isPrefixOf` s = ghcLibraryPath ++ drop 7 s
|
||||||
expand s = 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
|
-- 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.
|
-- 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
|
addStaticPkg pkg = modifyStaticPkgEnv env $ \set -> return $ S.insert pkg set
|
||||||
|
|
||||||
isStaticPkg :: PackageName -> IO Bool
|
isStaticPkg :: PackageName -> IO Bool
|
||||||
isStaticPkg pkg
|
isStaticPkg pkg = withStaticPkgEnv env $ \set -> return $ S.member pkg set
|
||||||
= case readP_to_S parsePackageName pkg of
|
|
||||||
((pkgName,_):_) -> withStaticPkgEnv env $ \set -> return $ S.member pkgName set
|
|
||||||
[] -> return False
|
|
||||||
|
|
||||||
--
|
--
|
||||||
-- Package path, given a package name, look it up in the environment and
|
-- 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
|
go (fm:fms) q = case lookupFM fm q of
|
||||||
Nothing -> go fms q -- look in other pkgs
|
Nothing -> go fms q -- look in other pkgs
|
||||||
|
|
||||||
Just package -> do
|
Just pkg -> do
|
||||||
let hslibs = hsLibraries package
|
let hslibs = hsLibraries pkg
|
||||||
extras' = extraLibraries package
|
extras' = extraLibraries pkg
|
||||||
cbits = filter (\e -> reverse (take (length "_cbits") (reverse e)) == "_cbits") extras'
|
cbits = filter (\e -> reverse (take (length "_cbits") (reverse e)) == "_cbits") extras'
|
||||||
extras = filter (flip notElem cbits) extras'
|
extras = filter (flip notElem cbits) extras'
|
||||||
ldopts = ldOptions package
|
ldopts = ldOptions pkg
|
||||||
deppkgs = packageDeps package
|
deppkgs = packageDeps pkg
|
||||||
ldInput <- mapM classifyLdInput ldopts
|
ldInput <- mapM classifyLdInput ldopts
|
||||||
let ldOptsLibs = [ path | Just (DLL path) <- ldInput ]
|
let ldOptsLibs = [ path | Just (DLL path) <- ldInput ]
|
||||||
ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ]
|
ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ]
|
||||||
dlls = map mkSOName (extras ++ ldOptsLibs)
|
dlls = map mkSOName (extras ++ ldOptsLibs)
|
||||||
#if defined(CYGWIN) || defined(__MINGW32__)
|
#if defined(CYGWIN) || defined(__MINGW32__)
|
||||||
libdirs = fix_topdir (libraryDirs package) ++ ldOptsPaths
|
libdirs = fix_topdir (libraryDirs pkg) ++ ldOptsPaths
|
||||||
#else
|
#else
|
||||||
libdirs = libraryDirs package ++ ldOptsPaths
|
libdirs = libraryDirs pkg ++ ldOptsPaths
|
||||||
#endif
|
#endif
|
||||||
-- If we're loading dynamic libs we need the cbits to appear before the
|
-- If we're loading dynamic libs we need the cbits to appear before the
|
||||||
-- real packages.
|
-- real packages.
|
||||||
@ -454,10 +467,10 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
|
|||||||
replace_topdir (x:xs) = x : replace_topdir xs
|
replace_topdir (x:xs) = x : replace_topdir xs
|
||||||
#endif
|
#endif
|
||||||
-- a list elimination form for the Maybe type
|
-- a list elimination form for the Maybe type
|
||||||
filterRight :: [Either left right] -> [right]
|
--filterRight :: [Either left right] -> [right]
|
||||||
filterRight [] = []
|
--filterRight [] = []
|
||||||
filterRight (Right x:xs) = x:filterRight xs
|
--filterRight (Right x:xs) = x:filterRight xs
|
||||||
filterRight (Left _:xs) = filterRight xs
|
--filterRight (Left _:xs) = filterRight xs
|
||||||
|
|
||||||
--
|
--
|
||||||
-- Check that a path to a library actually reaches a library
|
-- Check that a path to a library actually reaches a library
|
||||||
|
@ -69,8 +69,7 @@ import System.Plugins.LoadTypes
|
|||||||
-- import Language.Hi.Parser
|
-- import Language.Hi.Parser
|
||||||
import BinIface
|
import BinIface
|
||||||
import HscTypes
|
import HscTypes
|
||||||
import Module (moduleName, moduleNameString)
|
import Module (moduleName, moduleNameString, packageIdString)
|
||||||
import PackageConfig (packageIdString)
|
|
||||||
import HscMain (newHscEnv)
|
import HscMain (newHscEnv)
|
||||||
import TcRnMonad (initTcRnIf)
|
import TcRnMonad (initTcRnIf)
|
||||||
|
|
||||||
@ -97,7 +96,7 @@ readBinIface' :: FilePath -> IO ModIface
|
|||||||
readBinIface' hi_path = do
|
readBinIface' hi_path = do
|
||||||
-- kludgy as hell
|
-- kludgy as hell
|
||||||
e <- newHscEnv undefined
|
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
|
-- TODO need a loadPackage p package.conf :: IO () primitive
|
||||||
|
|
||||||
|
@ -75,7 +75,6 @@ import System.Directory ( doesFileExist, removeFile
|
|||||||
, getModificationTime )
|
, getModificationTime )
|
||||||
|
|
||||||
import Control.Exception ( handleJust )
|
import Control.Exception ( handleJust )
|
||||||
import GHC.IOBase ( Exception(IOException) )
|
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ >= 604
|
#if __GLASGOW_HASKELL__ >= 604
|
||||||
import System.IO.Error ( isDoesNotExistError )
|
import System.IO.Error ( isDoesNotExistError )
|
||||||
@ -148,7 +147,7 @@ make src args = rawMake src ("-c":args) True
|
|||||||
--
|
--
|
||||||
makeAll :: FilePath -> [Arg] -> IO MakeStatus
|
makeAll :: FilePath -> [Arg] -> IO MakeStatus
|
||||||
makeAll src args =
|
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
|
-- | This is a variety of 'make' that first calls 'merge' to
|
||||||
-- combine the plugin source with a syntax stub. The result is then
|
-- 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?
|
-- does this work in the presence of hier plugins?
|
||||||
-- won't handle hier names properly.
|
-- won't handle hier names properly.
|
||||||
|
|
||||||
let ghc_opts = [ "-Onot" ]
|
let ghc_opts = [ "-O0" ]
|
||||||
output = [ "-o", obj, "-odir", odir,
|
output = [ "-o", obj, "-odir", odir,
|
||||||
"-hidir", odir, "-i" ++ 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)
|
rm_f f = handleJust doesntExist (\_->return ()) (removeFile f)
|
||||||
where
|
where
|
||||||
doesntExist (IOException ioe)
|
doesntExist ioe
|
||||||
| isDoesNotExistError ioe = Just ()
|
| isDoesNotExistError ioe = Just ()
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
doesntExist _ = Nothing
|
|
||||||
|
|
||||||
readFile' f = do
|
readFile' f = do
|
||||||
h <- openFile f ReadMode
|
h <- openFile f ReadMode
|
||||||
|
@ -40,7 +40,8 @@ module System.Plugins.PackageAPI (
|
|||||||
|
|
||||||
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
|
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
|
||||||
import Distribution.InstalledPackageInfo
|
import Distribution.InstalledPackageInfo
|
||||||
import Distribution.Package hiding (depends, packageName)
|
import Distribution.Package hiding (depends, packageName, PackageName(..))
|
||||||
|
import Distribution.Text
|
||||||
#else
|
#else
|
||||||
import System.Plugins.Package
|
import System.Plugins.Package
|
||||||
#endif
|
#endif
|
||||||
@ -57,9 +58,9 @@ type PackageName = String
|
|||||||
|
|
||||||
type PackageConfig = InstalledPackageInfo
|
type PackageConfig = InstalledPackageInfo
|
||||||
|
|
||||||
packageName = showPackageId . package
|
packageName = display . package
|
||||||
packageName_ = pkgName . package
|
packageName_ = pkgName . package
|
||||||
packageDeps = (map showPackageId) . depends
|
packageDeps = (map display) . depends
|
||||||
|
|
||||||
updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) =
|
updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) =
|
||||||
pk { importDirs = f idirs }
|
pk { importDirs = f idirs }
|
||||||
|
Loading…
x
Reference in New Issue
Block a user