wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Updating for GHC 6.10

Browse Source
This commit is contained in:
alson 2009-01-31 23:16:26 +00:00
parent 80291eec13
commit 9d431c68a3
6 changed files with 61 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
plugins.cabal
View File

@ -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

18
src/System/MkTemp.hs
View File

@ -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

69
src/System/Plugins/Env.hs
View File

@ -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

5
src/System/Plugins/Load.hs
View File

@ -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

8
src/System/Plugins/Make.hs
View File

@ -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

7
src/System/Plugins/PackageAPI.hs
View File

@ -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 }