Updating for GHC 6.10

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,
+    build-depends:        base  >= 4,
-                          Cabal >= 1.4 && < 1.5,
+                          Cabal >= 1.6,
                           haskell-src,
                           containers,
                           array,
                           directory,
                           random,
                           process,
-                          ghc >= 6.8
+                          ghc >= 6.10,
+                          ghc-prim
 

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), 
+import GHC.IOBase                (IOException(..), IOErrorType(AlreadyExists) )
-                                  Exception(IOException), 
-                                  IOErrorType(AlreadyExists) )
 
 #ifndef __MINGW32__
 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
-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

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 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.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'
+        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
 
 -- 
@@ -309,9 +311,14 @@ grabDefaultPkgConf = do
 --
 readPackageConf :: FilePath -> IO [PackageConfig]
 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
       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
+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
@@ -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
+            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'
                        extras  = filter (flip notElem cbits) extras'
-                       ldopts  = ldOptions package
+                       ldopts  = ldOptions pkg
-                       deppkgs = packageDeps package
+                       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 :: [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

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 Module (moduleName, moduleNameString, packageIdString)
-import PackageConfig (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
 

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

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 }