diff --git a/plugins.cabal b/plugins.cabal --- a/plugins.cabal +++ b/plugins.cabal @@ -1,5 +1,5 @@ name: plugins -version: 1.5.4.0 +version: 1.5.5.0 homepage: http://hub.darcs.net/stepcut/plugins synopsis: Dynamic linking for Haskell and C objects description: Dynamic linking and runtime evaluation of Haskell, @@ -20,7 +20,12 @@ maintainer: Jeremy Shaw cabal-version: >= 1.6 build-type: Configure -Tested-with: GHC >= 6.12.1 +Tested-with: GHC == 7.0.* +-- not working , GHC == 7.2.* + , GHC == 7.4.* + , GHC == 7.6.* + , GHC == 7.8.* + , GHC == 7.10.* 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, @@ -59,3 +64,7 @@ if impl(ghc >= 7.2) build-depends: ghc-paths + +source-repository head + type: git + location: https://github.com/stepcut/plugins diff --git a/src/System/Eval.hs b/src/System/Eval.hs --- a/src/System/Eval.hs +++ b/src/System/Eval.hs @@ -1,25 +1,24 @@ --- +-- -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. --- +-- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA --- +-- -module System.Eval ( +module System.Eval ( module System.Eval.Haskell, ) where import System.Eval.Haskell {-all-} - diff --git a/src/System/Eval/Utils.hs b/src/System/Eval/Utils.hs --- a/src/System/Eval/Utils.hs +++ b/src/System/Eval/Utils.hs @@ -93,4 +93,3 @@ -- cleanup :: String -> String -> IO () cleanup a b = mapM_ removeFile [a, b, replaceSuffix b ".hi"] - diff --git a/src/System/Plugins.hs b/src/System/Plugins.hs --- a/src/System/Plugins.hs +++ b/src/System/Plugins.hs @@ -1,23 +1,23 @@ --- +-- -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. --- +-- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA --- +-- -module System.Plugins ( +module System.Plugins ( -- $Description @@ -34,4 +34,3 @@ -- -- [@NAME@] hs-plugins library : compile and load Haskell code at runtime -- - diff --git a/src/System/Plugins/Consts.hs b/src/System/Plugins/Consts.hs --- a/src/System/Plugins/Consts.hs +++ b/src/System/Plugins/Consts.hs @@ -1,22 +1,22 @@ {-# LANGUAGE CPP #-} --- +-- -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. --- +-- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA --- +-- module System.Plugins.Consts where @@ -60,7 +60,7 @@ -- | '_' on a.out, and Darwin #if LEADING_UNDERSCORE == 1 -prefixUnderscore = "_" +prefixUnderscore = "_" #else prefixUnderscore = "" #endif diff --git a/src/System/Plugins/Env.hs b/src/System/Plugins/Env.hs --- a/src/System/Plugins/Env.hs +++ b/src/System/Plugins/Env.hs @@ -1,22 +1,22 @@ {-# LANGUAGE CPP #-} -- -- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. --- +-- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA --- +-- module System.Plugins.Env ( env, @@ -69,11 +69,14 @@ import Control.Concurrent.MVar ( MVar(), newMVar, withMVar ) -import Distribution.Package hiding (depends, packageName, PackageName(..)) +import Distribution.Package hiding (depends, packageName, PackageName(..) +#if MIN_VERSION_ghc(7,10,0) + , installedPackageId +#endif + ) import Distribution.Text import Distribution.InstalledPackageInfo --- import Distribution.Package hiding (packageName, PackageName(..)) import Distribution.Simple.Compiler import Distribution.Simple.GHC import Distribution.Simple.PackageIndex @@ -93,7 +96,7 @@ addToFM :: (Ord key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt addToFM = \m k e -> M.insert k e m -addWithFM :: (Ord key) +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 @@ -147,9 +150,9 @@ -- multiple package.conf's kept in separate namespaces type PkgEnvs = [PkgEnv] -type Env = (MVar (), +type Env = (MVar (), IORef ModEnv, - IORef DepEnv, + IORef DepEnv, IORef PkgEnvs, IORef StaticPkgEnv, IORef MergeEnv) @@ -160,7 +163,7 @@ -- packages and their informations. Initially all we know is the default -- package.conf information. -- -env = unsafePerformIO $ do +env = unsafePerformIO $ do mvar <- newMVar () ref1 <- newIORef emptyFM -- loaded objects ref2 <- newIORef emptyFM @@ -202,10 +205,10 @@ modifyStaticPkgEnv :: Env -> (StaticPkgEnv -> IO StaticPkgEnv) -> IO () modifyMerged :: Env -> (MergeEnv -> IO MergeEnv)-> IO () -modifyModEnv (mvar,ref,_,_,_,_) f = lockAndWrite mvar ref f -modifyDepEnv (mvar,_,ref,_,_,_) f = lockAndWrite mvar ref f -modifyPkgEnv (mvar,_,_,ref,_,_) f = lockAndWrite mvar ref f -modifyStaticPkgEnv (mvar,_,_,_,ref,_) f = lockAndWrite mvar ref f +modifyModEnv (mvar,ref,_,_,_,_) f = lockAndWrite mvar ref f +modifyDepEnv (mvar,_,ref,_,_,_) f = lockAndWrite mvar ref f +modifyPkgEnv (mvar,_,_,ref,_,_) f = lockAndWrite mvar ref f +modifyStaticPkgEnv (mvar,_,_,_,ref,_) f = lockAndWrite mvar ref f modifyMerged (mvar,_,_,_,_,ref) f = lockAndWrite mvar ref f -- private @@ -285,7 +288,7 @@ -- stored in the environment. -- addPkgConf :: FilePath -> IO () -addPkgConf f = do +addPkgConf f = do ps <- readPackageConf f modifyPkgEnv env $ \ls -> return $ union ls ps @@ -295,22 +298,22 @@ -- GHC 6.12) -- union :: PkgEnvs -> [PackageConfig] -> PkgEnvs -union ls ps' = +union ls ps' = let fm = emptyFM -- new FM for this package.conf in foldr addOnePkg fm ps' : ls - where + where -- we add each package with and without it's version number and with the full installedPackageId addOnePkg p fm' = addToPkgEnvs (addToPkgEnvs (addToPkgEnvs fm' (display $ sourcePackageId p) p) (display $ installedPackageId p) p) (packageName p) p - + -- if no version number specified, pick the higher version addToPkgEnvs = addWithFM higherVersion - higherVersion pkgconf1 pkgconf2 + 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/ -- This imposes a constraint that you must build your plugins with the @@ -364,7 +367,7 @@ lookupPkg pn = go [] pn where go :: [PackageName] -> PackageName -> IO ([FilePath],[FilePath]) - go seen p = do + go seen p = do (ps, (f, g)) <- lookupPkg' p static <- isStaticPkg p (f', g') <- liftM unzip $ mapM (go (nub $ seen ++ ps)) (ps \\ seen) @@ -426,37 +429,37 @@ #else libdirs = libraryDirs pkg ++ ldOptsPaths #endif - -- If we're loading dynamic libs we need the cbits to appear before the - -- real packages. + -- If we're loading dynamic libs we need the cbits to appear before the + -- real packages. libs <- mapM (findHSlib libdirs) (cbits ++ hslibs) #if defined(CYGWIN) || defined(__MINGW32__) windowsos <- catch (getEnv "OS") - (\e -> if isDoesNotExistError e then return "Windows_98" else ioError e) + (\e -> if isDoesNotExistError e then return "Windows_98" else ioError e) windowsdir <- if windowsos == "Windows_9X" -- I don't know Windows 9X has OS system variable then return "C:/windows" else return "C:/winnt" sysroot <- catch (getEnv "SYSTEMROOT") - (\e -> if isDoesNotExistError e then return windowsdir else ioError e) -- guess at a reasonable default - let syslibdir = sysroot ++ (if windowsos == "Windows_9X" then "/SYSTEM" else "/SYSTEM32") - libs' <- mapM (findDLL $ syslibdir : libdirs) dlls + (\e -> if isDoesNotExistError e then return windowsdir else ioError e) -- guess at a reasonable default + let syslibdir = sysroot ++ (if windowsos == "Windows_9X" then "/SYSTEM" else "/SYSTEM32") + libs' <- mapM (findDLL $ syslibdir : libdirs) dlls #else - libs' <- mapM (findDLL libdirs) dlls + libs' <- mapM (findDLL libdirs) dlls #endif - let slibs = [ lib | Right (Static lib) <- libs ] - dlibs = [ lib | Right (Dynamic lib) <- libs ] + let slibs = [ lib | Right (Static lib) <- libs ] + dlibs = [ lib | Right (Dynamic lib) <- libs ] return (deppkgs, (slibs,map (either id id) libs' ++ dlibs) ) #if defined(CYGWIN) || defined(__MINGW32__) -- replace $topdir - fix_topdir [] = [] - fix_topdir (x:xs) = replace_topdir x : fix_topdir xs + fix_topdir [] = [] + fix_topdir (x:xs) = replace_topdir x : fix_topdir xs replace_topdir [] = [] - replace_topdir ('$':xs) - | take 6 xs == "topdir" = ghcLibraryPath ++ (drop 6 xs) - | otherwise = '$' : replace_topdir xs - replace_topdir (x:xs) = x : replace_topdir xs + replace_topdir ('$':xs) + | take 6 xs == "topdir" = ghcLibraryPath ++ (drop 6 xs) + | otherwise = '$' : replace_topdir xs + replace_topdir (x:xs) = x : replace_topdir xs #endif -- a list elimination form for the Maybe type --filterRight :: [Either left right] -> [right] @@ -474,31 +477,31 @@ if b then return $ Just l -- found it! else findHSlib' dirs lib - findHSslib dirs lib = findHSlib' dirs $ lib ++ sysPkgSuffix - findHSdlib dirs lib = findHSlib' dirs $ mkDynPkgName lib + findHSslib dirs lib = findHSlib' dirs $ lib ++ sysPkgSuffix + findHSdlib dirs lib = findHSlib' dirs $ mkDynPkgName lib -- Problem: sysPkgSuffix is ".o", but extra libraries could be -- ".so" -- Solution: first look for static library, if we don't find it - -- look for a dynamic version. - findHSlib :: [FilePath] -> String -> IO (Either String HSLib) - findHSlib dirs lib = do - static <- findHSslib dirs lib - case static of - Just file -> return $ Right $ Static file - Nothing -> do - dynamic <- findHSdlib dirs lib - case dynamic of - Just file -> return $ Right $ Dynamic file - Nothing -> return $ Left lib + -- look for a dynamic version. + findHSlib :: [FilePath] -> String -> IO (Either String HSLib) + findHSlib dirs lib = do + static <- findHSslib dirs lib + case static of + Just file -> return $ Right $ Static file + Nothing -> do + dynamic <- findHSdlib dirs lib + case dynamic of + Just file -> return $ Right $ Dynamic file + Nothing -> return $ Left lib findDLL :: [FilePath] -> String -> IO (Either String FilePath) - findDLL [] lib = return (Left lib) - findDLL (dir:dirs) lib = do - let l = dir lib - b <- doesFileExist l - if b then return $ Right l - else findDLL dirs lib + findDLL [] lib = return (Left lib) + findDLL (dir:dirs) lib = do + let l = dir lib + b <- doesFileExist l + if b then return $ Right l + else findDLL dirs lib ------------------------------------------------------------------------ -- do we have a Module name for this merge? @@ -533,7 +536,7 @@ -packageName :: PackageConfig -> PackageName +packageName :: PackageConfig -> PackageName packageDeps :: PackageConfig -> [PackageName] -- updImportDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig -- updLibraryDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig diff --git a/src/System/Plugins/Load.hs b/src/System/Plugins/Load.hs --- a/src/System/Plugins/Load.hs +++ b/src/System/Plugins/Load.hs @@ -72,7 +72,11 @@ -- import Language.Hi.Parser import BinIface import HscTypes +#if MIN_VERSION_ghc(7,10,0) +import Module (moduleName, moduleNameString, packageKeyString) +#else import Module (moduleName, moduleNameString, packageIdString) +#endif import HscMain (newHscEnv) import TcRnMonad (initTcRnIf) @@ -606,7 +610,7 @@ putStr (' ':show libs) >> hFlush stdout putStr (' ':show dlls) >> hFlush stdout #endif - mapM_ loadShared dlls + mapM_ loadShared dlls @@ -701,7 +705,9 @@ -- and find some packages to load, as well. let ps = dep_pkgs ds -#if MIN_VERSION_ghc(7,2,0) +#if MIN_VERSION_ghc(7,10,0) + ps' <- filterM loaded . map packageKeyString . nub $ map fst ps +#elif MIN_VERSION_ghc(7,2,0) ps' <- filterM loaded . map packageIdString . nub $ map fst ps #else ps' <- filterM loaded . map packageIdString . nub $ ps diff --git a/src/System/Plugins/LoadTypes.hs b/src/System/Plugins/LoadTypes.hs --- a/src/System/Plugins/LoadTypes.hs +++ b/src/System/Plugins/LoadTypes.hs @@ -1,22 +1,22 @@ --- +-- -- Copyright (c) 2005 Lemmih -- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as -- published by the Free Software Foundation; either version 2 of -- the License, or (at your option) any later version. --- +-- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. --- +-- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. --- +-- module System.Plugins.LoadTypes ( Key (..) diff --git a/src/System/Plugins/Make.hs b/src/System/Plugins/Make.hs --- a/src/System/Plugins/Make.hs +++ b/src/System/Plugins/Make.hs @@ -1,27 +1,27 @@ {-# LANGUAGE CPP #-} --- +-- -- Copyright (C) 2004..2010 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. --- +-- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA --- +-- -- | An interface to a Haskell compiler, providing the facilities of a -- compilation manager. -module System.Plugins.Make ( +module System.Plugins.Make ( -- * The @MakeStatus@ type MakeStatus(..), @@ -30,9 +30,9 @@ MakeCode(..), -- * Compiling Haskell modules - make, + make, makeAll, - makeWith, + makeWith, -- * Handling reecompilation hasChanged, @@ -40,12 +40,12 @@ recompileAll, recompileAll', - -- * Merging together Haskell source files + -- * Merging together Haskell source files MergeStatus(..), MergeCode, Args, Errors, - merge, + merge, mergeTo, mergeToDir, @@ -88,16 +88,16 @@ -- messages produced by the compiler. @MakeSuccess@ returns a @MakeCode@ -- value, and the path to the object file produced. -- -data MakeStatus +data MakeStatus = MakeSuccess MakeCode FilePath -- ^ compilation was successful | MakeFailure Errors -- ^ compilation failed deriving (Eq,Show) -- | The @MakeCode@ type is used when compilation is successful, to --- distinguish two cases: +-- distinguish two cases: -- * The source file needed recompiling, and this was done -- * The source file was already up to date, recompilation was skipped -data MakeCode +data MakeCode = ReComp -- ^ recompilation was performed | NotReq -- ^ recompilation was not required deriving (Eq,Show) @@ -105,12 +105,12 @@ -- -- | An equivalent status for the preprocessor phase -- -data MergeStatus +data MergeStatus = MergeSuccess MergeCode Args FilePath -- ^ the merge was successful | MergeFailure Errors -- ^ failure, and any errors returned deriving (Eq,Show) --- +-- -- | Merging may be avoided if the source files are older than an -- existing merged result. The @MergeCode@ type indicates whether -- merging was performed, or whether it was unneccessary. @@ -131,7 +131,7 @@ -- in the 'args' parameter, they will be appended to the argument list. -- @make@ always recompiles its target, whether or not it is out of -- date. --- +-- -- A side-effect of calling 'make' is to have GHC produce a @.hi@ file -- containing a list of package and objects that the source depends on. -- Subsequent calls to 'load' will use this interface file to load @@ -147,7 +147,7 @@ -- the first argument. -- makeAll :: FilePath -> [Arg] -> IO MakeStatus -makeAll src args = +makeAll src args = rawMake src ( "--make":"-no-hs-main":"-c":"-v0":args ) False -- | This is a variety of 'make' that first calls 'merge' to @@ -163,7 +163,7 @@ -- > a = 1 -- -- and --- +-- -- > module B where -- > a :: Int -- @@ -176,7 +176,7 @@ -- > a :: Int -- > {-# LINE 4 "A.hs" #-} -- > a = 1 --- +-- makeWith :: FilePath -- ^ a src file -> FilePath -- ^ a syntax stub file -> [Arg] -- ^ any required args @@ -215,7 +215,7 @@ _ -> return True -- --- | 'recompileAll' is like 'makeAll', but rather than relying on +-- | 'recompileAll' is like 'makeAll', but rather than relying on -- @ghc --make@, we explicitly check a module\'s dependencies using our -- internal map of module dependencies. Performance is thus better, and -- the result is more accurate. @@ -265,16 +265,16 @@ ; src_changed <- if docheck then src `newer` obj else return True ; if not src_changed then return $ MakeSuccess NotReq obj - else do -#if DEBUG + else do +#if DEBUG putStr "Compiling object ... " >> hFlush stdout #endif err <- build src obj args -#if DEBUG +#if DEBUG putStrLn "done" #endif - return $ if null err - then MakeSuccess ReComp obj + return $ if null err + then MakeSuccess ReComp obj else MakeFailure err } @@ -296,7 +296,7 @@ -- won't handle hier names properly. let ghc_opts = [ "-O0" ] - output = [ "-o", obj, "-odir", odir, + output = [ "-o", obj, "-odir", odir, "-hidir", odir, "-i" ++ odir ] let flags = ghc_opts ++ output ++ extra_opts ++ [src] @@ -322,7 +322,7 @@ -- syntax. An EDSL user then need not worry about declaring module -- names, or having required imports. In this way, the stub file can -- also be used to provide syntax declarations that would be --- inconvenient to require of the plugin author. +-- inconvenient to require of the plugin author. -- -- 'merge' will include any import and export declarations written in -- the stub, as well as any module name, so that plugin author\'s need @@ -337,7 +337,7 @@ -- parse Haskell source files. -- merge :: FilePath -> FilePath -> IO MergeStatus -merge src stb = do +merge src stb = do m_mod <- lookupMerged src stb (out,domerge) <- case m_mod of Nothing -> do out <- mkUnique @@ -347,7 +347,7 @@ rawMerge src stb out domerge -- | 'mergeTo' behaves like 'merge', but we can specify the file in --- which to place output. +-- which to place output. mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus mergeTo src stb out = rawMerge src stb out False @@ -378,12 +378,12 @@ src_exists <- doesFileExist src stb_exists <- doesFileExist stb case () of {_ - | not src_exists -> return $ + | not src_exists -> return $ MergeFailure ["Source file does not exist : "++src] - | not stb_exists -> return $ + | not stb_exists -> return $ MergeFailure ["Source file does not exist : "++stb] | otherwise -> do { - + ;do_merge <- do src_changed <- src `newer` out stb_changed <- stb `newer` out return $ src_changed || stb_changed @@ -400,7 +400,7 @@ let e_src_syn = parse src src_str e_stb_syn = parse stb stb_str - + -- check if there were parser errors case (e_src_syn,e_stb_syn) of (Left e, _) -> return $ MergeFailure [e] @@ -429,7 +429,7 @@ makeCleaner :: FilePath -> IO () makeCleaner f = makeClean f >> rm_f (dropSuffix f <> hsSuf) - + -- internal: -- try to remove a file, ignoring if it didn't exist in the first place -- Doesn't seem to be able to remove all files in all circumstances, why? @@ -446,4 +446,3 @@ length s `seq` return () hClose h return s - diff --git a/src/System/Plugins/Parser.hs b/src/System/Plugins/Parser.hs --- a/src/System/Plugins/Parser.hs +++ b/src/System/Plugins/Parser.hs @@ -1,25 +1,25 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} --- +-- -- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as -- published by the Free Software Foundation; either version 2 of -- the License, or (at your option) any later version. --- +-- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. --- +-- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. --- +-- -module System.Plugins.Parser ( +module System.Plugins.Parser ( parse, mergeModules, pretty, parsePragmas, HsModule(..) , replaceModName @@ -27,7 +27,7 @@ #include "../../../config.h" -import Data.List +import Data.List import Data.Char import Data.Either ( ) @@ -41,12 +41,12 @@ -- -- | parse a file (as a string) as Haskell src --- +-- parse :: FilePath -- ^ module name -> String -- ^ haskell src -> Either String HsModule -- ^ abstract syntax -parse f fsrc = +parse f fsrc = #if defined(WITH_HSX) case parseFileContentsWithMode (ParseMode f) fsrc of #else @@ -55,8 +55,8 @@ ParseOk src -> Right src ParseFailed loc _ -> Left $ srcmsg loc where - srcmsg loc = "parse error in " ++ f ++ "\n" ++ - "line: " ++ (show $ srcLine loc) ++ + srcmsg loc = "parse error in " ++ f ++ "\n" ++ + "line: " ++ (show $ srcLine loc) ++ ", col: " ++ (show $ srcColumn loc)++ "\n" -- @@ -88,23 +88,23 @@ mergeModules (HsModule l _ _ is ds ) (HsModule _ m' es' is' ds') - = (HsModule l m' es' - (mImps m' is is') + = (HsModule l m' es' + (mImps m' is is') (mDecl ds ds') ) --- +-- -- | replace Module name with String. -- replaceModName :: HsModule -> String -> HsModule replaceModName (HsModule l _ es is ds) nm = (HsModule l (Module nm) es is ds) --- +-- -- | merge import declarations: -- -- * ensure that the config file doesn't import the stub name -- * merge import lists uniquely, and when they match, merge their decls -- --- TODO * we don't merge imports of the same module from both files. +-- TODO * we don't merge imports of the same module from both files. -- We should, and then merge the decls in their import list -- * rename args, too confusing. -- @@ -115,9 +115,9 @@ [HsImportDecl] -> -- stub file imports [HsImportDecl] -mImps plug_mod cimps timps = +mImps plug_mod cimps timps = case filter (!~ self) cimps of cimps' -> unionBy (=~) cimps' timps - where + where self = ( HsImportDecl undefined plug_mod undefined undefined undefined ) -- @@ -152,7 +152,7 @@ (=~) :: a -> a -> Bool (!~) :: a -> a -> Bool n !~ m = not (n =~ m) - + instance SynEq HsDecl where (HsPatBind _ (HsPVar n) _ _) =~ (HsPatBind _ (HsPVar m) _ _) = n == m (HsTypeSig _ (n:_) _) =~ (HsTypeSig _ (m:_) _) = n == m @@ -170,7 +170,7 @@ -- handle -package options, and other /static/ flags. This is more than -- GHC. -- --- GHC user's guide : +-- GHC user's guide : -- -- > OPTIONS pragmas are only looked for at the top of your source -- > files, up to the first (non-literate,non-empty) line not diff --git a/src/System/Plugins/Process.hs b/src/System/Plugins/Process.hs --- a/src/System/Plugins/Process.hs +++ b/src/System/Plugins/Process.hs @@ -79,11 +79,11 @@ -- generate 1000s of lines of output. -- popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID) -popen f s m = +popen f s m = E.handle (\e -> return ([], show (e::IOException), error $ show e )) $ do - x@(_,_,pid) <- P.popen f s m + x@(_,_,pid) <- P.popen f s m b <- P.getProcessStatus True False pid -- wait - return $ case b of + return $ case b of Nothing -> ([], "process has disappeared", pid) _ -> x diff --git a/src/System/Plugins/Utils.hs b/src/System/Plugins/Utils.hs --- a/src/System/Plugins/Utils.hs +++ b/src/System/Plugins/Utils.hs @@ -1,24 +1,24 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} --- +-- -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. --- +-- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA --- +-- -module System.Plugins.Utils ( +module System.Plugins.Utils ( Arg, hWrite, @@ -104,7 +104,7 @@ {- -mkstemps path slen = do +mkstemps path slen = do withCString path $ \ ptr -> do let c_slen = fromIntegral $ slen+1 fd <- throwErrnoIfMinus1 "mkstemps" $ c_mkstemps ptr c_slen @@ -148,18 +148,18 @@ hMkUnique :: IO (FilePath,Handle) hMkUnique = do (t,h) <- mkTemp alreadyLoaded <- isLoaded t -- not unique! - if alreadyLoaded + if alreadyLoaded then hClose h >> removeFile t >> hMkUnique else return (t,h) mkUniqueIn :: FilePath -> IO FilePath mkUniqueIn dir = do (t,h) <- hMkUniqueIn dir - hClose h >> return t + hClose h >> return t hMkUniqueIn :: FilePath -> IO (FilePath,Handle) hMkUniqueIn dir = do (t,h) <- mkTempIn dir alreadyLoaded <- isLoaded t -- not unique! - if alreadyLoaded + if alreadyLoaded then hClose h >> removeFile t >> hMkUniqueIn dir else return (t,h) @@ -307,7 +307,7 @@ -- replaceSuffix :: FilePath -> String -> FilePath replaceSuffix [] _ = [] -- ? -replaceSuffix f suf = +replaceSuffix f suf = case reverse $ dropWhile (/= '.') $ reverse f of [] -> f ++ suf -- no '.' in file name f' -> f' ++ tail suf @@ -316,7 +316,7 @@ -- Normally we create the .hi and .o files next to the .hs files. -- For some uses this is annoying (i.e. true EDSL users don't actually -- want to know that their code is compiled at all), and for hmake-like --- applications. +-- applications. -- -- This code checks if "-o foo" or "-odir foodir" are supplied as args -- to make(), and if so returns a modified file path, otherwise it @@ -337,7 +337,7 @@ | otherwise -> (mk_o src, mk_hi src) } - where + where outpath = "-o" outdir = "-odir" @@ -414,7 +414,7 @@ decode_upper 'C' = ':' decode_upper 'Z' = 'Z' decode_upper ch = error $ "decode_upper can't handle this char `"++[ch]++"'" - + decode_lower 'z' = 'z' decode_lower 'a' = '&' decode_lower 'b' = '|' @@ -505,4 +505,3 @@ isSublistOf x y@(_:ys) | isPrefixOf x y = True | otherwise = isSublistOf x ys -