Adapt to work with GHC 6.12

- Adapted the package to work with GHC 6.12
- Plugins that depend on the old base3 are currently
  not correctly loaded as the plugin loaded misses
  the dependence on syb (leading to unresolved symbols)
- Cleaned up most of the testsuite (there are still
  some outstanding failures, of which only one
  demonstrates a bug in the plugins library as far
  as I can see — see previous bullet point)
- Cleaned out a little cruft (but more could be done)

Setup.lhs

@@ -2,4 +2,4 @@
 > module Main where
 > import Distribution.Simple
 > main :: IO ()
-> main = defaultMainWithHooks defaultUserHooks
+> main = defaultMainWithHooks autoconfUserHooks

plugins.cabal

@@ -1,5 +1,5 @@
 name:               plugins
-version:            1.4.1
+version:            1.5.1
 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,
@@ -14,6 +14,7 @@ author:             Don Stewart 2004-2009
 maintainer:         Don Stewart <dons@galois.com>
 cabal-version:      >= 1.6
 build-type:         Configure
+Tested-with:        GHC >= 6.12.1
 extra-source-files: config.guess, config.h.in, config.mk.in, config.sub,
                     configure, configure.ac, install.sh, Makefile,
                     testsuite/makewith/io/TestIO.conf.in,
@@ -46,6 +47,7 @@ library
                           containers,
                           array,
                           directory,
+                          filepath,
                           random,
                           process,
                           ghc >= 6.10,

src/System/Eval/Haskell.hs

@@ -51,11 +51,11 @@ import System.Plugins.Load
 import Data.Dynamic             ( Dynamic )
 import Data.Typeable            ( Typeable )
 
-import Data.Either
+import Data.Either              ( )
 import Data.Map as Map
 import Data.Char
 
-import System.IO
+import System.IO                ( )
 import System.Directory
 import System.Random
 import System.IO.Unsafe
@@ -122,7 +122,7 @@ eval_ src mods args ldflags incs = do
     pwd                <- getCurrentDirectory
     (cmdline,loadpath) <- getPaths      -- find path to altdata
     tmpf               <- mkUniqueWith dynwrap src mods
-    status             <- make tmpf $ ["-Onot"] ++ cmdline ++ args
+    status             <- make tmpf $ ["-O0"] ++ cmdline ++ args
     m_rsrc <- case status of
         MakeSuccess _ obj -> do
            m_v <- dynload obj (pwd:incs) (loadpath++ldflags) symbol

src/System/Eval/Utils.hs

@@ -71,7 +71,7 @@ escape s = concatMap (\c -> showLitChar c $ "") s
 --
 getPaths :: IO ([String],[String])
 getPaths = do
-        let make_line = ["-Onot","-fglasgow-exts","-package","plugins"]
+        let make_line = ["-O0","-fglasgow-exts","-package","plugins"]
         return (make_line,[])
 
 -- ---------------------------------------------------------------------

src/System/MkTemp.hs

@@ -36,7 +36,7 @@ module System.MkTemp (
 
   ) where
 
-import Data.List
+import Data.List                ( )
 import Data.Char                ( chr, ord, isDigit )
 import Control.Monad            ( liftM )
 import Control.Exception        ( handleJust )
@@ -44,13 +44,12 @@ import System.FilePath          ( splitFileName, (</>) )
 import System.Directory         ( doesDirectoryExist, doesFileExist, createDirectory )
 import System.IO
 #ifndef __MINGW32__
-import System.IO.Error          ( isAlreadyExistsError )
+import System.IO.Error          ( mkIOError, alreadyExistsErrorType,
+                                  isAlreadyExistsError )
 #else
 import System.IO.Error          ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError )
 #endif
 
-import GHC.IOBase                (IOException(..), IOErrorType(AlreadyExists) )
-
 #ifndef __MINGW32__
 import qualified System.Posix.Internals ( c_getpid )
 #endif
@@ -216,7 +215,7 @@ open0600 f = do
         if b then ioError err   -- race
              else openFile f ReadWriteMode
     where
-        err = IOError Nothing AlreadyExists "open0600" "already exists" Nothing
+        err = mkIOError alreadyExistsErrorType "op0600" Nothing (Just f)
 
 {-
 -- open(path, O_CREAT|O_EXCL|O_RDWR, 0600)

src/System/Plugins/Env.hs

@@ -52,16 +52,16 @@ module System.Plugins.Env (
 
 import System.Plugins.LoadTypes (Module)
 import System.Plugins.PackageAPI  {- everything -}
-import System.Plugins.Consts           ( sysPkgConf, sysPkgSuffix )
+import System.Plugins.Consts           ( sysPkgSuffix )
+
+import Control.Monad            ( liftM )
 
 import Data.IORef               ( writeIORef, readIORef, newIORef, IORef() )
 import Data.Maybe               ( isJust, isNothing, fromMaybe )
-import Data.List                ( isInfixOf, nub )
+import Data.List                ( nub )
 
 import System.IO.Unsafe         ( unsafePerformIO )
-import System.IO                ( hGetContents )
 import System.Directory         ( doesFileExist )
-import System.Process           ( waitForProcess, runInteractiveCommand )
 #if defined(CYGWIN) || defined(__MINGW32__)
 import Prelude hiding ( catch, ioError )
 import System.IO.Error          ( catch, ioError, isDoesNotExistError )
@@ -91,6 +91,10 @@ emptyFM   = M.empty
 addToFM :: (Ord key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt
 addToFM   = \m k e -> M.insert k e m
 
+addWithFM :: (Ord key) 
+          => (elt -> elt -> elt) -> FiniteMap key elt -> key -> elt -> FiniteMap key elt
+addWithFM   = \comb m k e -> M.insertWith comb k e m
+
 delFromFM :: (Ord key) => FiniteMap key elt -> key -> FiniteMap key elt
 delFromFM = flip M.delete
 
@@ -160,7 +164,9 @@ env = unsafePerformIO $ do
                 ref2  <- newIORef emptyFM
                 p     <- grabDefaultPkgConf
                 ref3  <- newIORef p               -- package.conf info
-                ref4  <- newIORef (S.fromList ["base","Cabal-1.1.6","haskell-src-1.0"]) -- FIXME
+                ref4  <- newIORef (S.fromList ["base","Cabal","haskell-src", "containers",
+                                               "arrays", "directory", "random", "process",
+                                               "ghc", "ghc-prim"])
                 ref5  <- newIORef emptyFM         -- merged files
                 return (mvar, ref1, ref2, ref3, ref4, ref5)
 {-# NOINLINE env #-}
@@ -282,16 +288,26 @@ addPkgConf f = do
     modifyPkgEnv env $ \ls -> return $ union ls ps
 
 --
--- | add a new FM for the package.conf to the list of existing ones
+-- | add a new FM for the package.conf to the list of existing ones; if a package occurs multiple
+-- times, pick the one with the higher version number as the default (e.g., important for base in
+-- GHC 6.12)
 --
 union :: PkgEnvs -> [PackageConfig] -> PkgEnvs
 union ls ps' = 
         let fm = emptyFM -- new FM for this package.conf
-        in foldr (\p fm' -> if (display $ package p) == "base" -- ghc doesn't supply a version with 'base'
+        in foldr addOnePkg fm ps' : ls
-                                                       -- for some reason.
+    where 
-                            then addToFM (addToFM fm' (display $ package p) p) (packageName p) p
+      -- we add each package with and without it's version number
-                            else addToFM fm' (packageName p) p) fm ps' : ls
+      addOnePkg p fm' = addToPkgEnvs (addToPkgEnvs fm' (display $ sourcePackageId p) p)
+                                     (packageName p) p
+      
+      -- if no version number specified, pick the higher version
+      addToPkgEnvs = addWithFM higherVersion
 
+      higherVersion pkgconf1 pkgconf2 
+        | installedPackageId pkgconf1 >= installedPackageId pkgconf2 = pkgconf1
+        | otherwise                                                  = pkgconf2
+        
 -- 
 -- | generate a PkgEnv from the system package.conf
 -- The path to the default package.conf was determined by /configure/
@@ -300,11 +316,10 @@ union ls ps' =
 --
 
 grabDefaultPkgConf :: IO PkgEnvs
-
 grabDefaultPkgConf = do
-        pkg_confs <- get_ghc_configs
+        pc <- configureAllKnownPrograms silent defaultProgramConfiguration
-        packages <- mapM readPackageConf pkg_confs
+        pkgIndex <- getInstalledPackages silent [GlobalPackageDB, UserPackageDB] pc
-        return $ foldl union [] packages
+        return $ [] `union` allPackages pkgIndex
 
 --
 -- parse a source file, expanding any $libdir we see.
@@ -312,7 +327,7 @@ grabDefaultPkgConf = do
 readPackageConf :: FilePath -> IO [PackageConfig]
 readPackageConf f = do
     pc <- configureAllKnownPrograms silent defaultProgramConfiguration
-    pkgIndex <- getInstalledPackages silent (SpecificPackageDB f) pc
+    pkgIndex <- getInstalledPackages silent [GlobalPackageDB, UserPackageDB, SpecificPackageDB f] pc
     return $ allPackages pkgIndex
 
 -- -----------------------------------------------------------
@@ -345,13 +360,10 @@ isStaticPkg pkg = withStaticPkgEnv env $ \set -> return $ S.member pkg set
 --
 lookupPkg :: PackageName -> IO ([FilePath],[FilePath])
 lookupPkg p = do 
-        t <- lookupPkg' p
+        (ps, (f, g)) <- lookupPkg' p
         static <- isStaticPkg p
-        case t of ([],(f,g)) -> return (f,if static then [] else g)
+        (f', g') <- liftM unzip $ mapM lookupPkg ps
-                  (ps,(f,g)) -> do gss <- mapM lookupPkg ps
+        return $ (nub $ (concat f') ++ f, if static then [] else nub $ (concat g') ++ g)
-				   let (f',g') = unzip gss
-				   return $ (nub $ (concat f') ++ f
-                                            ,if static then [] else nub $ (concat g') ++ g)
 
 data LibrarySpec
    = DLL String         -- -lLib
@@ -506,25 +518,3 @@ addMerge a b z = modifyMerged env $ \fm -> return $ addToFM fm (a,b) z
 [] </> b = b
 a  </> b = a ++ "/" ++ b
 
--------------------------------------------------------------------------
---
--- 'run_cmd' executes command and returns it's standard output
--- as 'String'
-
-run_cmd :: String -> IO String
-run_cmd cmd = do (_hI, hO, _hE, hProcess) <- runInteractiveCommand cmd
-                 output <- hGetContents hO
-                 _exitCode <- waitForProcess hProcess
-                 return output
---
--- 'get_ghc_configs' returns list of strings of packages.conf files in system
-
-get_ghc_configs :: IO [String]
-get_ghc_configs = do ghc_out <- run_cmd "ghc-pkg list"
-                     let configs = map (reverse.strip_trash.reverse) $
-                                   filter (isInfixOf sysPkgConf) $ lines ghc_out
-                     return configs
-                         -- | strip ":\r?" from string head
-                         where strip_trash [] = []
-                               strip_trash xs@(x:xs') | x `elem` ":\r" = strip_trash xs'
-                                                      | otherwise      = xs

src/System/Plugins/Load.hs

@@ -81,6 +81,7 @@ import Control.Monad            ( when, filterM, liftM )
 import System.Directory         ( doesFileExist, removeFile )
 import Foreign.C.String         ( CString, withCString, peekCString )
 
+import GHC                      ( defaultCallbacks )
 import GHC.Ptr                  ( Ptr(..), nullPtr )
 import GHC.Exts                 ( addrToHValue# )
 import GHC.Prim                 ( unsafeCoerce# )
@@ -95,7 +96,7 @@ ifaceModuleName = moduleNameString . moduleName . mi_module
 readBinIface' :: FilePath -> IO ModIface
 readBinIface' hi_path = do
     -- kludgy as hell
-    e <- newHscEnv undefined
+    e <- newHscEnv defaultCallbacks undefined
     initTcRnIf 'r' e undefined undefined (readBinIface IgnoreHiWay QuietBinIFaceReading hi_path)
 
 -- TODO need a loadPackage p package.conf :: IO () primitive
@@ -438,7 +439,7 @@ loadFunction__ pkg m valsym
 #if DEBUG
         putStrLn $ "Looking for <<"++symbol++">>"
 #endif
-        ptr@(~(Ptr addr)) <- withCString symbol c_lookupSymbol
+        ptr@(Ptr addr) <- withCString symbol c_lookupSymbol
         if (ptr == nullPtr)
             then return Nothing
             else case addrToHValue# addr of
@@ -706,7 +707,7 @@ getImports m = do
 -- ---------------------------------------------------------------------
 -- C interface
 --
-foreign import ccall threadsafe "lookupSymbol"
+foreign import ccall safe "lookupSymbol"
    c_lookupSymbol :: CString -> IO (Ptr a)
 
 foreign import ccall unsafe "loadObj"

src/System/Plugins/PackageAPI.hs

@@ -58,8 +58,8 @@ type PackageName = String
 
 type PackageConfig = InstalledPackageInfo
 
-packageName = display . package
+packageName = display . pkgName . sourcePackageId
-packageName_ = pkgName . package
+packageName_ = pkgName . sourcePackageId
 packageDeps = (map display) . depends
 
 updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) =

src/System/Plugins/Parser.hs

@@ -28,7 +28,7 @@ module System.Plugins.Parser (
 
 import Data.List 
 import Data.Char
-import Data.Either
+import Data.Either ( )
 
 #if defined(WITH_HSX)
 import Language.Haskell.Hsx

src/System/Plugins/Process.hs

@@ -14,7 +14,7 @@ import Control.Concurrent       (forkIO)
 import qualified Posix as P
 #endif
 
-import qualified Control.OldException as E
+import qualified Control.Exception as E
 
 --
 -- slight wrapper over popen for calls that don't care about stdin to the program
@@ -38,7 +38,7 @@ type ProcessID = ProcessHandle
 --
 popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ProcessID)
 popen file args minput =
-    E.handle (\e -> return ([],show e, error (show e))) $ do
+    E.handle (\e -> return ([],show (e::E.IOException), error (show e))) $ do
 
     (inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing
 
@@ -55,8 +55,8 @@ popen file args minput =
     -- data gets pulled as it becomes available. you have to force the
     -- output strings before waiting for the process to terminate.
     --
-    forkIO (E.evaluate (length output) >> return ())
+    _ <- forkIO (E.evaluate (length output) >> return ())
-    forkIO (E.evaluate (length errput) >> 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 file args minput =
 --
 popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID)
 popen f s m = 
-        E.handle (\e -> return ([], show e, error $ show e )) $ do
+        E.handle (\e -> return ([], show (e::IOException), error $ show e )) $ do
             x@(_,_,pid) <- P.popen f s m 
             b <- P.getProcessStatus True False pid  -- wait
             return $ case b of    

testsuite/build.mk

@@ -13,7 +13,7 @@ REALBIN=	./Main
 API_OBJ=	api/API.o
 
 INCLUDES=   	-i$(TOP)/testsuite/$(TEST)/api
-GHCFLAGS=   	-Onot -cpp -fglasgow-exts
+GHCFLAGS=   	-O0 -cpp -fglasgow-exts
 
 .SUFFIXES : .o .hs .hi .lhs .hc .s
 

testsuite/dynload/io/TestIO.hs

@@ -7,7 +7,7 @@
 module TestIO ( resource_dyn )  where
 
 import API
-import AltData.Dynamic
+import Data.Dynamic
 
 import System.IO
 import System.Posix.Types   ( ProcessID, Fd )

testsuite/dynload/io/api/API.hs

@@ -2,7 +2,7 @@
 
 module API where
 
-import AltData.Typeable
+import Data.Typeable
 
 data TestIO = TestIO { 
                 field :: IO String 

testsuite/dynload/poly/Plugin.hs

@@ -1,7 +1,7 @@
 module Plugin where
 
 import API
-import AltData.Dynamic
+import Data.Dynamic
 
 my_fun = plugin { 
                 equals = \x y -> (x /= y)  -- a strange equals function :)

testsuite/dynload/poly/api/API.hs

@@ -2,7 +2,7 @@
 
 module API where
 
-import AltData.Typeable
+import Data.Typeable
 
 data Interface = Interface { 
         equals :: forall t. Eq t => t -> t -> Bool

testsuite/dynload/should_fail/Plugin.hs

@@ -2,7 +2,7 @@
 module Plugin where
 
 import API
-import AltData.Dynamic
+import Data.Dynamic
 
 v :: Int
 v = 0xdeadbeef

testsuite/dynload/should_fail/api/API.hs

@@ -2,7 +2,7 @@
 
 module API where
 
-import AltData.Typeable
+import Data.Typeable
 
 data Interface = Interface { 
         function :: String

testsuite/dynload/should_fail_1/Plugin.hs

@@ -5,7 +5,7 @@
 module Plugin where
 
 import API
-import AltData.Dynamic
+import Data.Dynamic
 
 v :: Int -> Int
 v = \x -> 0xdeadbeef

testsuite/dynload/should_fail_1/api/API.hs

@@ -2,7 +2,7 @@
 
 module API where
 
-import AltData.Typeable
+import Data.Typeable
 
 data Interface = Interface { 
         function :: String

testsuite/dynload/should_fail_2/Plugin.in

@@ -9,7 +9,7 @@
 module Plugin where
 
 import API
-import AltData.Typeable
+import Data.Typeable
 import GHC.Base
 
 v :: Int

testsuite/dynload/should_fail_2/Plugin.stub

@@ -3,7 +3,7 @@
 module Plugin ( resource_dyn )  where
 
 import API
-import AltData.Dynamic
+import Data.Dynamic
 
 resource = plugin
 

testsuite/dynload/should_fail_2/api/API.hs

@@ -2,7 +2,7 @@
 
 module API where
 
-import AltData.Typeable
+import Data.Typeable
 import GHC.Base
 
 data Interface = Interface { 

testsuite/dynload/should_fail_3/Plugin.in

@@ -9,7 +9,7 @@ module Plugin where
 
 import API
 
-import AltData.Typeable
+import Data.Typeable
 import GHC.Base
 
 v :: Int

testsuite/dynload/should_fail_3/Plugin.stub

@@ -3,7 +3,7 @@
 module Plugin ( resource_dyn )  where
 
 import API
-import AltData.Dynamic
+import Data.Dynamic
 
 resource = plugin
 

testsuite/dynload/should_fail_3/api/API.hs

@@ -2,7 +2,7 @@
 
 module API where
 
-import AltData.Typeable
+import Data.Typeable
 import GHC.Base
 
 data Interface = Interface { 

testsuite/dynload/simple/Plugin.hs

@@ -2,7 +2,7 @@
 module Plugin where
 
 import API
-import AltData.Dynamic
+import Data.Dynamic
 
 my_fun = plugin { function = "plugin says \"hello\"" }
 

testsuite/dynload/simple/api/API.hs

@@ -2,7 +2,7 @@
 
 module API where
 
-import AltData.Typeable
+import Data.Typeable
 
 data Interface = Interface { 
         function :: String

testsuite/eval/eval_fn1/Poly.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS -cpp -fglasgow-exts #-} 
 module Poly where
 
-import AltData.Typeable
+import Data.Typeable
 
 data Fn = Fn {fn :: forall t. Eq t => t -> t -> Bool}
 

testsuite/hier/hier1/prog/Main.hs

@@ -9,8 +9,7 @@ import System.Plugins
 import API
 import Modules.Flags as Flags
 
-
+record = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 }
-rec = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 }
 
 
 main = do
@@ -18,4 +17,4 @@ main = do
         case status of
                 LoadFailure _ -> error "load failed"
                 LoadSuccess _ v -> do let func = dbFunc v
-                                      print (func rec)
+                                      print (func record)

testsuite/misc/mkstemps/Main.hs

@@ -36,7 +36,7 @@ main = do
 
         () <- if (not $ all isJust ts)
               then putStrLn $ "mkstemp couldn't create all expected files"
-              else putStrLn $ "mkstemp:	created "++(show $ length $ catMaybes ts)++" files"
+              else putStrLn $ "mkstemp: created "++(show $ length $ catMaybes ts)++" files"
         rmAll ts
 
         ------------------------------------------------------------------------
@@ -47,7 +47,7 @@ main = do
                                      _ -> return v ) [1..2000]
         () <- if (not $ all isJust ts)
               then putStrLn $ "mkstemps couldn't create all expected files"
-              else putStrLn $ "mkstemps:	created "++(show $ length $ catMaybes ts)++" files"
+              else putStrLn $ "mkstemps: created "++(show $ length $ catMaybes ts)++" files"
         rmAll ts
 
         ------------------------------------------------------------------------
@@ -55,8 +55,8 @@ main = do
         --
         ts <- mapM (\_ -> mkdtemp "t/XXXXXXXXXX") [1..2000]
         () <- if (not $ all isJust ts)
-              then putStrLn $ "mkdtemp:	couldn't create all expected directories"
+              then putStrLn $ "mkdtemp: couldn't create all expected directories"
-              else putStrLn $ "mkdtemp:	created "++(show $ length $ catMaybes ts)++" directories"
+              else putStrLn $ "mkdtemp: created "++(show $ length $ catMaybes ts)++" directories"
         rmAllDirs ts
     
         ------------------------------------------------------------------------

testsuite/misc/mkstemps/expected

@@ -1,5 +1,5 @@
 created 53 files
 correctly ran out of permutations
-mkstemp:	created 10000 files
+mkstemp: created 10000 files
-mkstemps:	created 2000 files
+mkstemps: created 2000 files
-mkdtemp:	created 2000 directories
+mkdtemp: created 2000 directories

testsuite/objc/expression_parser/PluginEvalAux.hs

@@ -15,7 +15,7 @@ symbol = "resource"
 
 evalWithStringResult :: FilePath -> String -> IO String
 evalWithStringResult srcFile s = do
-  status <- make srcFile ["-Onot"]
+  status <- make srcFile ["-O0"]
   case status of
       MakeFailure err   -> putStrLn "error occured" >> return (show err)
       MakeSuccess _ obj -> load' obj

testsuite/pdynload/poly/Plugin.hs

@@ -1,9 +1,11 @@
 module Plugin where
 
+import Data.Typeable
+import Data.Generics.Aliases
 import Data.Generics.Schemes
 
 import API
 
 resource = rsrc { 
-     field = id listify
+     field = id listify :: Typeable r => (r -> Bool) -> GenericQ [r]
 }

testsuite/plugs/runplugs/Makefile

@@ -1,4 +1,4 @@
-GHCFLAGS=   -Onot $(GHC_EXTRA_OPTS)
+GHCFLAGS=   -O0 $(GHC_EXTRA_OPTS)
 PKGFLAGS=   -package posix
 PKGFLAGS+=  -package plugins