From 1a3efdd6b616f3a101e182f715df5a0e306eb348 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 8 Feb 2008 12:41:32 +0000 Subject: [PATCH] Remove some of the old compat stuff now that we assume GHC 6.4 --- compat/Compat/Directory.hs | 170 ----------------------------------------- compat/Compat/RawSystem.hs | 156 ------------------------------------- compat/compat.mk | 3 - compiler/deSugar/Coverage.lhs | 4 - compiler/main/Packages.lhs | 4 - compiler/main/SysTools.lhs | 7 -- utils/ghc-pkg/Main.hs | 8 +- utils/hsc2hs/Main.hs | 4 - utils/runghc/Makefile | 7 -- utils/runghc/runghc.hs | 5 -- 10 files changed, 1 insertion(+), 367 deletions(-) delete mode 100644 compat/Compat/Directory.hs delete mode 100644 compat/Compat/RawSystem.hs diff --git a/compat/Compat/Directory.hs b/compat/Compat/Directory.hs deleted file mode 100644 index 983f083..0000000 --- a/compat/Compat/Directory.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Compat.Directory --- Copyright : (c) The University of Glasgow 2001-2004 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- Functions from System.Directory that aren't present in older versions --- of that library. --- ------------------------------------------------------------------------------ - -module Compat.Directory ( - getAppUserDataDirectory, - copyFile, - findExecutable, - createDirectoryIfMissing - ) where - -#include "../../includes/ghcconfig.h" - -import System.Environment (getEnv) -import System.FilePath -#if __GLASGOW_HASKELL__ > 600 -import Control.Exception ( bracket ) -import Control.Monad ( when ) -import Foreign.Marshal.Alloc ( allocaBytes ) -import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose) -import System.IO.Error ( try ) -import GHC.IOBase ( IOException(..) ) -#if defined(mingw32_HOST_OS) -import GHC.IOBase ( IOErrorType(..) ) -#endif -#else -import System.IO ( try ) -#endif -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) -import Foreign -import Foreign.C -#endif -import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory) - -getAppUserDataDirectory :: String -> IO FilePath -getAppUserDataDirectory appName = do -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) - allocaBytes long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath - when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory") - s <- peekCString pPath - return (s++'\\':appName) -#else - path <- getEnv "HOME" - return (path++'/':'.':appName) -#endif - -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) -foreign import ccall unsafe "directory.h __hscore_getFolderPath" - c_SHGetFolderPath :: Ptr () - -> CInt - -> Ptr () - -> CInt - -> CString - -> IO CInt - --- __compat_long_path_size defined in cbits/directory.c -foreign import ccall unsafe "directory.h __compat_long_path_size" - long_path_size :: Int - -foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt - -raiseUnsupported loc = - ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) -#endif - - -copyFile :: FilePath -> FilePath -> IO () -copyFile fromFPath toFPath = -#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600)) - do readFile fromFPath >>= writeFile toFPath - try (getPermissions fromFPath >>= setPermissions toFPath) - return () -#else - (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> - bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> - allocaBytes bufferSize $ \buffer -> do - copyContents hFrom hTo buffer - try (getPermissions fromFPath >>= setPermissions toFPath) - return ()) `catch` (ioError . changeFunName) - where - bufferSize = 1024 - - changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp - - copyContents hFrom hTo buffer = do - count <- hGetBuf hFrom buffer bufferSize - when (count > 0) $ do - hPutBuf hTo buffer count - copyContents hFrom hTo buffer -#endif - --- | Given an executable file name, searches for such file --- in the directories listed in system PATH. The returned value --- is the path to the found executable or Nothing if there isn't --- such executable. For example (findExecutable \"ghc\") --- gives you the path to GHC. -findExecutable :: String -> IO (Maybe FilePath) -findExecutable binary = -#if defined(mingw32_HOST_OS) - withCString binary $ \c_binary -> - withCString ('.':exeExtension) $ \c_ext -> - allocaBytes long_path_size $ \pOutPath -> - alloca $ \ppFilePart -> do - res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart - if res > 0 && res < fromIntegral long_path_size - then do fpath <- peekCString pOutPath - return (Just fpath) - else return Nothing - -foreign import stdcall unsafe "SearchPathA" - c_SearchPath :: CString - -> CString - -> CString - -> CInt - -> CString - -> Ptr CString - -> IO CInt -#else - do - path <- getEnv "PATH" - search (splitSearchPath path) - where - fileName = binary <.> exeExtension - - search :: [FilePath] -> IO (Maybe FilePath) - search [] = return Nothing - search (d:ds) = do - let path = d fileName - b <- doesFileExist path - if b then return (Just path) - else search ds -#endif - --- ToDo: This should be determined via autoconf (AC_EXEEXT) --- | Extension for executable files --- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) -exeExtension :: String -#ifdef mingw32_HOST_OS -exeExtension = "exe" -#else -exeExtension = "" -#endif - --- | @'createDirectoryIfMissing' parents dir@ creates a new directory --- @dir@ if it doesn\'t exist. If the first argument is 'True' --- the function will also create all parent directories if they are missing. -createDirectoryIfMissing :: Bool -- ^ Create its parents too? - -> FilePath -- ^ The path to the directory you want to make - -> IO () -createDirectoryIfMissing parents file = do - b <- doesDirectoryExist file - case (b,parents, file) of - (_, _, "") -> return () - (True, _, _) -> return () - (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file - (_, False, _) -> createDirectory file - where mkParents = scanl1 () . splitDirectories . normalise diff --git a/compat/Compat/RawSystem.hs b/compat/Compat/RawSystem.hs deleted file mode 100644 index f0f8aa3..0000000 --- a/compat/Compat/RawSystem.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Compat.RawSystem --- Copyright : (c) The University of Glasgow 2001-2004 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- This is an implementation of rawSystem for use on older versions of GHC --- which had missing or buggy implementations of this function. --- ------------------------------------------------------------------------------ - -module Compat.RawSystem (rawSystem) where - -#include "../../includes/ghcconfig.h" - -#if __GLASGOW_HASKELL__ >= 603 - -import System.Cmd (rawSystem) - -#else /* to end of file */ - -import System.Exit -import Foreign -import Foreign.C - -{- | -The computation @'rawSystem' cmd args@ runs the operating system command -whose file name is @cmd@, passing it the arguments @args@. It -bypasses the shell, so that @cmd@ should see precisely the argument -strings @args@, with no funny escaping or shell meta-syntax expansion. -(Unix users will recognise this behaviour -as @execvp@, and indeed that's how it's implemented.) -It will therefore behave more portably between operating systems than 'system'. - -The return codes are the same as for 'system'. --} - -rawSystem :: FilePath -> [String] -> IO ExitCode - -{- ------------------------------------------------------------------------- - IMPORTANT IMPLEMENTATION NOTES - (see also libraries/base/cbits/rawSystem.c) - -On Unix, rawSystem is easy to implement: use execvp. - -On Windows it's more tricky. We use CreateProcess, passing a single -command-line string (lpCommandLine) as its argument. (CreateProcess -is well documented on http://msdn.microsoft/com.) - - - It parses the beginning of the string to find the command. If the - file name has embedded spaces, it must be quoted, using double - quotes thus - "foo\this that\cmd" arg1 arg2 - - - The invoked command can in turn access the entire lpCommandLine string, - and the C runtime does indeed do so, parsing it to generate the - traditional argument vector argv[0], argv[1], etc. It does this - using a complex and arcane set of rules which are described here: - - http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp - - (if this URL stops working, you might be able to find it by - searching for "Parsing C Command-Line Arguments" on MSDN. Also, - the code in the Microsoft C runtime that does this translation - is shipped with VC++). - - -Our goal in rawSystem is to take a command filename and list of -arguments, and construct a string which inverts the translatsions -described above, such that the program at the other end sees exactly -the same arguments in its argv[] that we passed to rawSystem. - -This inverse translation is implemented by 'translate' below. - -Here are some pages that give informations on Windows-related -limitations and deviations from Unix conventions: - - http://support.microsoft.com/default.aspx?scid=kb;en-us;830473 - Command lines and environment variables effectively limited to 8191 - characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x): - - http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp - Command-line substitution under Windows XP. IIRC these facilities (or at - least a large subset of them) are available on Win NT and 2000. Some - might be available on Win 9x. - - http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp - How CMD.EXE processes command lines. - - -Note: CreateProcess does have a separate argument (lpApplicationName) -with which you can specify the command, but we have to slap the -command into lpCommandLine anyway, so that argv[0] is what a C program -expects (namely the application name). So it seems simpler to just -use lpCommandLine alone, which CreateProcess supports. - ------------------------------------------------------------------------------ -} - -#ifndef mingw32_HOST_OS - -rawSystem cmd args = - withCString cmd $ \pcmd -> - withMany withCString (cmd:args) $ \cstrs -> - withArray0 nullPtr cstrs $ \arr -> do - status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr) - case status of - 0 -> return ExitSuccess - n -> return (ExitFailure n) - -foreign import ccall unsafe "rawSystem" - c_rawSystem :: CString -> Ptr CString -> IO Int - -#else - --- On Windows, the command line is passed to the operating system as --- a single string. Command-line parsing is done by the executable --- itself. -rawSystem cmd args = do - -- NOTE: 'cmd' is assumed to contain the application to run _only_, - -- as it'll be quoted surrounded in quotes here. - let cmdline = translate cmd ++ concat (map ((' ':) . translate) args) - withCString cmdline $ \pcmdline -> do - status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline) - case status of - 0 -> return ExitSuccess - n -> return (ExitFailure n) - -translate :: String -> String -translate str@('"':_) = str -- already escaped. - -- ToDo: this case is wrong. It is only here because we - -- abuse the system in GHC's SysTools by putting arguments into - -- the command name; at some point we should fix it up and remove - -- the case above. -translate str = '"' : snd (foldr escape (True,"\"") str) - where escape '"' (b, str) = (True, '\\' : '"' : str) - escape '\\' (True, str) = (True, '\\' : '\\' : str) - escape '\\' (False, str) = (False, '\\' : str) - escape c (b, str) = (False, c : str) - -- See long comment above for what this function is trying to do. - -- - -- The Bool passed back along the string is True iff the - -- rest of the string is a sequence of backslashes followed by - -- a double quote. - -foreign import ccall unsafe "rawSystem" - c_rawSystem :: CString -> IO Int - -#endif - -#endif - diff --git a/compat/compat.mk b/compat/compat.mk index 4740510..8101021 100644 --- a/compat/compat.mk +++ b/compat/compat.mk @@ -36,8 +36,6 @@ endif # This is horrible. We ought to be able to omit the entire directory # from mkDependHS. SRC_MKDEPENDHS_OPTS += \ - -optdep--exclude-module=Compat.RawSystem \ - -optdep--exclude-module=Compat.Directory \ -optdep--exclude-module=Compat.Unicode \ -optdep--exclude-module=Distribution.Compat.FilePath \ -optdep--exclude-module=Distribution.Compat.ReadP \ @@ -52,7 +50,6 @@ SRC_MKDEPENDHS_OPTS += \ -optdep--exclude-module=System.FilePath \ -optdep--exclude-module=System.FilePath.Posix \ -optdep--exclude-module=System.FilePath.Windows \ - -optdep--exclude-module=System.Directory.Internals \ -optdep--exclude-module=Trace.Hpc.Mix \ -optdep--exclude-module=Trace.Hpc.Tix \ -optdep--exclude-module=Trace.Hpc.Util diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index e97ab42..6d6f1f0 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -29,11 +29,7 @@ import FiniteMap import Data.Array import System.IO (FilePath) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 -import Compat.Directory ( createDirectoryIfMissing ) -#else import System.Directory ( createDirectoryIfMissing ) -#endif import Trace.Hpc.Mix import Trace.Hpc.Util diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index ad841b2..d1feff7 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -54,10 +54,6 @@ import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 -import Compat.Directory ( getAppUserDataDirectory ) -#endif - import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo import Distribution.Package diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 6aa04b1..484e9e2 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -72,17 +72,10 @@ import Foreign import CString ( CString, peekCString ) #endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 --- rawSystem comes from libghccompat.a in stage1 -import Compat.RawSystem ( rawSystem ) -import System.Cmd ( system ) -import GHC.IOBase ( IOErrorType(..) ) -#else import System.Process ( runInteractiveProcess, getProcessExitCode ) import Control.Concurrent( forkIO, newChan, readChan, writeChan ) import FastString ( mkFastString ) import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) -#endif \end{code} diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 866c9fe..ae85fbc 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -22,14 +22,8 @@ import Distribution.ParseUtils import Distribution.Package import Distribution.Version import System.FilePath - -#ifdef USING_COMPAT -import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) -import Compat.RawSystem ( rawSystem ) -#else -import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) import System.Cmd ( rawSystem ) -#endif +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) import Prelude diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs index a5bd774..a939f31 100644 --- a/utils/hsc2hs/Main.hs +++ b/utils/hsc2hs/Main.hs @@ -42,11 +42,7 @@ import System.IO ( openFile, IOMode(..), hClose ) #endif #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC) -#ifdef USING_COMPAT -import Compat.RawSystem ( rawSystem ) -#else import System.Cmd ( rawSystem ) -#endif #define HAVE_rawSystem #elif __NHC__ >= 117 import System.Cmd ( rawSystem ) diff --git a/utils/runghc/Makefile b/utils/runghc/Makefile index 16e9724..a7303f9 100644 --- a/utils/runghc/Makefile +++ b/utils/runghc/Makefile @@ -7,13 +7,6 @@ INSTALL_PROGS += $(HS_PROG) UseGhcForCc = YES SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) -# This causes libghccompat.a to be used: -include $(GHC_COMPAT_DIR)/compat.mk - -# This is required because libghccompat.a must be built with -# $(GhcHcOpts) because it is linked to the compiler, and hence -# we must also build with $(GhcHcOpts) here: -SRC_HC_OPTS += $(GhcHcOpts) $(GhcStage1HcOpts) SRC_HC_OPTS += -Wall RUNHASKELL_PROG = runhaskell$(exeext) diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs index 458861e..e2cea31 100644 --- a/utils/runghc/runghc.hs +++ b/utils/runghc/runghc.hs @@ -30,12 +30,7 @@ import Data.Char import System.Directory ( removeFile ) import Control.Exception ( bracket ) import System.Directory ( findExecutable, getTemporaryDirectory ) - -#ifdef USING_COMPAT -import Compat.RawSystem ( rawSystem ) -#else import System.Cmd ( rawSystem ) -#endif main :: IO () main = do -- 1.7.10.4