plugins 1.4.1 → 1.5.1
raw patch · 34 files changed
+94/−99 lines, 34 filesdep +filepathdep ~basedep ~ghcsetup-changed
Dependencies added: filepath
Dependency ranges changed: base, ghc
Files
- Setup.lhs +1/−1
- plugins.cabal +4/−2
- src/System/Eval/Haskell.hs +3/−3
- src/System/Eval/Utils.hs +1/−1
- src/System/MkTemp.hs +8/−7
- src/System/Plugins/Env.hs +33/−43
- src/System/Plugins/Load.hs +4/−3
- src/System/Plugins/PackageAPI.hs +2/−2
- src/System/Plugins/Parser.hs +1/−1
- src/System/Plugins/Process.hs +5/−5
- testsuite/build.mk +1/−1
- testsuite/dynload/io/TestIO.hs +1/−1
- testsuite/dynload/io/api/API.hs +1/−1
- testsuite/dynload/poly/Plugin.hs +1/−1
- testsuite/dynload/poly/api/API.hs +1/−1
- testsuite/dynload/should_fail/Plugin.hs +1/−1
- testsuite/dynload/should_fail/api/API.hs +1/−1
- testsuite/dynload/should_fail_1/Plugin.hs +1/−1
- testsuite/dynload/should_fail_1/api/API.hs +1/−1
- testsuite/dynload/should_fail_2/Plugin.in +1/−1
- testsuite/dynload/should_fail_2/Plugin.stub +1/−1
- testsuite/dynload/should_fail_2/api/API.hs +1/−1
- testsuite/dynload/should_fail_3/Plugin.in +1/−1
- testsuite/dynload/should_fail_3/Plugin.stub +1/−1
- testsuite/dynload/should_fail_3/api/API.hs +1/−1
- testsuite/dynload/simple/Plugin.hs +1/−1
- testsuite/dynload/simple/api/API.hs +1/−1
- testsuite/eval/eval_fn1/Poly.hs +1/−1
- testsuite/hier/hier1/prog/Main.hs +2/−3
- testsuite/misc/mkstemps/Main.hs +4/−4
- testsuite/misc/mkstemps/expected +3/−3
- testsuite/objc/expression_parser/PluginEvalAux.hs +1/−1
- testsuite/pdynload/poly/Plugin.hs +3/−1
- testsuite/plugs/runplugs/Makefile +1/−1
Setup.lhs view
@@ -2,4 +2,4 @@ > module Main where > import Distribution.Simple > main :: IO ()-> main = defaultMainWithHooks defaultUserHooks+> main = defaultMainWithHooks autoconfUserHooks
plugins.cabal view
@@ -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 @@ 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,@@ -40,12 +41,13 @@ extensions: CPP, ForeignFunctionInterface ghc-options: -Wall -funbox-strict-fields -fno-warn-missing-signatures hs-source-dirs: src- build-depends: base >= 4,+ build-depends: base >= 4 && < 5, Cabal >= 1.6, haskell-src, containers, array, directory,+ filepath, random, process, ghc >= 6.10,
src/System/Eval/Haskell.hs view
@@ -51,11 +51,11 @@ 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 @@ 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 view
@@ -71,7 +71,7 @@ -- 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 view
@@ -36,20 +36,20 @@ ) where -import Data.List+import Data.List ( ) import Data.Char ( chr, ord, isDigit ) import Control.Monad ( liftM ) import Control.Exception ( handleJust )+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@@ -90,8 +90,9 @@ -- firstly, break up the path and extract the template -- let (pref,tmpl,suff) = let (r,s) = splitAt (length path - slen) path- (p,t) = break (== 'X') r- in (p,t,s)+ (d,f) = splitFileName r + (p,t) = break (== 'X') f+ in (d </> p,t,s) -- -- an error if there is only a suffix, it seems --@@ -214,7 +215,7 @@ 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 view
@@ -52,16 +52,16 @@ 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 @@ 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 @@ 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 @@ 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'- -- for some reason.- then addToFM (addToFM fm' (display $ package p) p) (packageName p) p- else addToFM fm' (packageName p) p) fm ps' : ls+ in foldr addOnePkg fm ps' : ls+ where + -- we add each package with and without it's version number+ 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 @@ -- grabDefaultPkgConf :: IO PkgEnvs- grabDefaultPkgConf = do- pkg_confs <- get_ghc_configs- packages <- mapM readPackageConf pkg_confs- return $ foldl union [] packages+ pc <- configureAllKnownPrograms silent defaultProgramConfiguration+ pkgIndex <- getInstalledPackages silent [GlobalPackageDB, UserPackageDB] pc+ return $ [] `union` allPackages pkgIndex -- -- parse a source file, expanding any $libdir we see.@@ -312,7 +327,7 @@ 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 @@ -- 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)- (ps,(f,g)) -> do gss <- mapM lookupPkg ps- let (f',g') = unzip gss- return $ (nub $ (concat f') ++ f- ,if static then [] else nub $ (concat g') ++ g)+ (f', g') <- liftM unzip $ mapM lookupPkg ps+ return $ (nub $ (concat f') ++ f, if static then [] else nub $ (concat g') ++ g) data LibrarySpec = DLL String -- -lLib@@ -506,25 +518,3 @@ [] </> 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 view
@@ -81,6 +81,7 @@ 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 @@ 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 @@ #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 @@ -- --------------------------------------------------------------------- -- 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 view
@@ -58,8 +58,8 @@ type PackageConfig = InstalledPackageInfo -packageName = display . package-packageName_ = pkgName . package+packageName = display . pkgName . sourcePackageId+packageName_ = pkgName . sourcePackageId packageDeps = (map display) . depends updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) =
src/System/Plugins/Parser.hs view
@@ -28,7 +28,7 @@ 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 view
@@ -14,7 +14,7 @@ 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 @@ -- 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 @@ -- 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 errput) >> return ())+ _ <- forkIO (E.evaluate (length output) >> 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 :: 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 view
@@ -13,7 +13,7 @@ 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 view
@@ -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 view
@@ -2,7 +2,7 @@ module API where -import AltData.Typeable+import Data.Typeable data TestIO = TestIO { field :: IO String
testsuite/dynload/poly/Plugin.hs view
@@ -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 view
@@ -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 view
@@ -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 view
@@ -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 view
@@ -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 view
@@ -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 view
@@ -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 view
@@ -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 view
@@ -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 view
@@ -9,7 +9,7 @@ import API -import AltData.Typeable+import Data.Typeable import GHC.Base v :: Int
testsuite/dynload/should_fail_3/Plugin.stub view
@@ -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 view
@@ -2,7 +2,7 @@ module API where -import AltData.Typeable+import Data.Typeable import GHC.Base data Interface = Interface {
testsuite/dynload/simple/Plugin.hs view
@@ -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 view
@@ -2,7 +2,7 @@ module API where -import AltData.Typeable+import Data.Typeable data Interface = Interface { function :: String
testsuite/eval/eval_fn1/Poly.hs view
@@ -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 view
@@ -9,8 +9,7 @@ import API import Modules.Flags as Flags --rec = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 }+record = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 } main = do@@ -18,4 +17,4 @@ 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 view
@@ -36,7 +36,7 @@ () <- 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 @@ _ -> 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 @@ -- ts <- mapM (\_ -> mkdtemp "t/XXXXXXXXXX") [1..2000] () <- if (not $ all isJust ts)- then putStrLn $ "mkdtemp: couldn't create all expected directories"- else putStrLn $ "mkdtemp: created "++(show $ length $ catMaybes ts)++" directories"+ then putStrLn $ "mkdtemp: couldn't create all expected directories"+ else putStrLn $ "mkdtemp: created "++(show $ length $ catMaybes ts)++" directories" rmAllDirs ts ------------------------------------------------------------------------
testsuite/misc/mkstemps/expected view
@@ -1,5 +1,5 @@ created 53 files correctly ran out of permutations-mkstemp: created 10000 files-mkstemps: created 2000 files-mkdtemp: created 2000 directories+mkstemp: created 10000 files+mkstemps: created 2000 files+mkdtemp: created 2000 directories
testsuite/objc/expression_parser/PluginEvalAux.hs view
@@ -15,7 +15,7 @@ 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 view
@@ -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 view
@@ -1,4 +1,4 @@-GHCFLAGS= -Onot $(GHC_EXTRA_OPTS)+GHCFLAGS= -O0 $(GHC_EXTRA_OPTS) PKGFLAGS= -package posix PKGFLAGS+= -package plugins