Commit 1fc9b0cc authored by Ben Millwood's avatar Ben Millwood

Drop code to handle unsupported compilers

This means tweaking CPP conditionals and file pragmas to remove handling
of compilers other than GHC, and GHC versions before LANGUAGE pragmas
existed.
parent b41b92c3
{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.CopyFile (
copyFile,
......@@ -14,7 +9,6 @@ module Distribution.Compat.CopyFile (
setDirOrdinary,
) where
#ifdef __GLASGOW_HASKELL__
import Control.Monad
( when )
......@@ -36,7 +30,6 @@ import System.IO
( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
import Foreign
( allocaBytes )
#endif /* __GLASGOW_HASKELL__ */
#ifndef mingw32_HOST_OS
import System.Posix.Internals (withFilePath)
......@@ -69,7 +62,6 @@ setFileExecutable _ = return ()
setDirOrdinary = setFileExecutable
copyFile :: FilePath -> FilePath -> IO ()
#ifdef __GLASGOW_HASKELL__
copyFile fromFPath toFPath =
copy
`catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))
......@@ -89,6 +81,3 @@ copyFile fromFPath toFPath =
when (count > 0) $ do
hPutBuf hTo buffer count
copyContents hFrom hTo buffer
#else
copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath
#endif
{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
#if !defined(__HUGS__)
#define NEW_EXCEPTION
#endif
module Distribution.Compat.Exception (
Exception.IOException,
onException,
......@@ -22,40 +11,17 @@ import System.Exit
import qualified Control.Exception as Exception
onException :: IO a -> IO b -> IO a
#ifdef NEW_EXCEPTION
onException = Exception.onException
#else
onException io what = io `Exception.catch` \e -> do what
Exception.throw e
#endif
throwIOIO :: Exception.IOException -> IO a
#ifdef NEW_EXCEPTION
throwIOIO = Exception.throwIO
#else
throwIOIO = Exception.throwIO . Exception.IOException
#endif
tryIO :: IO a -> IO (Either Exception.IOException a)
#ifdef NEW_EXCEPTION
tryIO = Exception.try
#else
tryIO = Exception.tryJust Exception.ioErrors
#endif
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
#ifdef NEW_EXCEPTION
catchIO = Exception.catch
#else
catchIO = Exception.catchJust Exception.ioErrors
#endif
catchExit :: IO a -> (ExitCode -> IO a) -> IO a
#ifdef NEW_EXCEPTION
catchExit = Exception.catch
#else
catchExit = Exception.catchJust exitExceptions
where exitExceptions (Exception.ExitException ee) = Just ee
exitExceptions _ = Nothing
#endif
{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.TempFile (
openTempFile,
......@@ -16,13 +11,6 @@ module Distribution.Compat.TempFile (
import System.FilePath ((</>))
import Foreign.C (eEXIST)
#if __NHC__ || __HUGS__
import System.IO (openFile, openBinaryFile,
Handle, IOMode(ReadWriteMode))
import System.Directory (doesFileExist)
import System.FilePath ((<.>), splitExtension)
import System.IO.Error (try, isAlreadyExistsError)
#else
import System.IO (Handle, openTempFile, openBinaryTempFile)
import Data.Bits ((.|.))
import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
......@@ -32,15 +20,9 @@ import System.Posix.Internals (withFilePath)
import Foreign.C (CInt)
import GHC.IO.Handle.FD (fdToHandle)
import Distribution.Compat.Exception (onException, tryIO)
#endif
import Foreign.C (getErrno, errnoToIOError)
#if __NHC__
import System.Posix.Types (CPid(..))
foreign import ccall unsafe "getpid" c_getpid :: IO CPid
#else
import System.Posix.Internals (c_getpid)
#endif
#ifdef mingw32_HOST_OS
import System.Directory ( createDirectory )
......@@ -56,43 +38,6 @@ import qualified System.Posix
-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
-- TODO: Not sure about jhc
#if __NHC__ || __HUGS__
-- use a temporary filename that doesn't already exist.
-- NB. *not* secure (we don't atomically lock the tmp file we get)
openTempFile :: FilePath -> String -> IO (FilePath, Handle)
openTempFile tmp_dir template
= do x <- getProcessID
findTempName x
where
(templateBase, templateExt) = splitExtension template
findTempName :: Int -> IO (FilePath, Handle)
findTempName x
= do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
b <- doesFileExist path
if b then findTempName (x+1)
else do hnd <- openFile path ReadWriteMode
return (path, hnd)
openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
openBinaryTempFile tmp_dir template
= do x <- getProcessID
findTempName x
where
(templateBase, templateExt) = splitExtension template
findTempName :: Int -> IO (FilePath, Handle)
findTempName x
= do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
b <- doesFileExist path
if b then findTempName (x+1)
else do hnd <- openBinaryFile path ReadWriteMode
return (path, hnd)
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile = openBinaryTempFile
getProcessID :: IO Int
getProcessID = fmap fromIntegral c_getpid
#else
-- This is a copy/paste of the openBinaryTempFile definition, but
-- if uses 666 rather than 600 for the permissions. The base library
-- needs to be changed to make this better.
......@@ -159,7 +104,6 @@ std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
rw_flags = output_flags .|. o_RDWR
#endif
createTempDirectory :: FilePath -> String -> IO FilePath
createTempDirectory dir template = do
......
{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
-- -fno-warn-deprecations for use of Map.foldWithKey
{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Configuration
......
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.InstallDirs
......@@ -559,9 +557,6 @@ getWindowsProgramFilesDir = do
#if mingw32_HOST_OS
shGetFolderPath :: CInt -> IO (Maybe FilePath)
shGetFolderPath n =
# if __HUGS__
return Nothing
# else
allocaArray long_path_size $ \pPath -> do
r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath
if (r /= 0)
......@@ -569,7 +564,6 @@ shGetFolderPath n =
else do s <- peekCWString pPath; return (Just s)
where
long_path_size = 1024 -- MAX_PATH is 260, this should be plenty
# endif
csidl_PROGRAM_FILES :: CInt
csidl_PROGRAM_FILES = 0x0026
......
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Utils
......@@ -141,10 +139,8 @@ module Distribution.Simple.Utils (
import Control.Monad
( when, unless, filterM )
#ifdef __GLASGOW_HASKELL__
import Control.Concurrent.MVar
( newEmptyMVar, putMVar, takeMVar )
#endif
import Data.List
( nub, unfoldr, isPrefixOf, tails, intercalate )
import Data.Char as Char
......@@ -176,10 +172,8 @@ import System.IO
import System.IO.Error as IO.Error
( isDoesNotExistError, isAlreadyExistsError
, ioeSetFileName, ioeGetFileName, ioeGetErrorString )
#if !defined(__HUGS__)
import System.IO.Error
( ioeSetLocation, ioeGetLocation )
#endif
import System.IO.Unsafe
( unsafeInterleaveIO )
import qualified Control.Exception as Exception
......@@ -196,16 +190,11 @@ import Distribution.Version
import Control.Exception (evaluate)
import System.Process (runProcess)
#ifdef __GLASGOW_HASKELL__
import Control.Concurrent (forkIO)
import System.Process (runInteractiveProcess, waitForProcess)
#if __GLASGOW_HASKELL__ >= 702
import System.Process (showCommandForUser)
#endif
#else
import System.Cmd (system)
import System.Directory (getTemporaryDirectory)
#endif
import Distribution.Compat.CopyFile
( copyFile, copyOrdinaryFile, copyExecutableFile
......@@ -239,12 +228,8 @@ dieWithLocation filename lineno msg =
. flip ioeSetFileName (normalise filename)
$ userError msg
where
#if defined(__HUGS__)
setLocation _ err = err
#else
setLocation Nothing err = err
setLocation (Just n) err = ioeSetLocation err (show n)
#endif
die :: String -> IO a
die msg = ioError (userError msg)
......@@ -262,13 +247,9 @@ topHandler prog = catchIO prog handle
file = case ioeGetFileName ioe of
Nothing -> ""
Just path -> path ++ location ++ ": "
#if defined(__HUGS__)
location = ""
#else
location = case ioeGetLocation ioe of
l@(n:_) | n >= '0' && n <= '9' -> ':' : l
_ -> ""
#endif
detail = ioeGetErrorString ioe
-- | Non fatal conditions that may be indicative of an error or problem.
......@@ -465,7 +446,6 @@ rawSystemStdInOut :: Verbosity
rawSystemStdInOut verbosity path args input outputBinary = do
printRawCommandAndArgs verbosity path args
#ifdef __GLASGOW_HASKELL__
Exception.bracket
(runInteractiveProcess path args Nothing Nothing)
(\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
......@@ -512,33 +492,6 @@ rawSystemStdInOut verbosity path args input outputBinary = do
" with error message:\n" ++ err
return (out, err, exitcode)
#else
tmpDir <- getTemporaryDirectory
withTempFile tmpDir ".cmd.stdout" $ \outName outHandle ->
withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do
hClose outHandle
case input of
Nothing -> return ()
Just (inputStr, inputBinary) -> do
hSetBinaryMode inHandle inputBinary
hPutStr inHandle inputStr
hClose inHandle
let quote name = "'" ++ name ++ "'"
cmd = unwords (map quote (path:args))
++ " <" ++ quote inName
++ " >" ++ quote outName
exitcode <- system cmd
unless (exitcode == ExitSuccess) $
debug verbosity $ path ++ " returned " ++ show exitcode
Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do
hSetBinaryMode hnd outputBinary
output <- hGetContents hnd
length output `seq` return (output, "", exitcode)
#endif
-- | Look for a program on the path.
......
{-# OPTIONS -cpp #-}
-----------------------------------------------------------------------------
-- | Separate module for HTTP actions, using a proxy server if one exists
-----------------------------------------------------------------------------
......
......@@ -42,11 +42,7 @@ import Data.Traversable
import Control.Applicative
( (<$>) )
import Control.Monad
( when, unless )
#if MIN_VERSION_base(3,0,0)
import Control.Monad
( (>=>), join )
#endif
( when, unless, (>=>), join )
import Control.Arrow
( (&&&), (***) )
......@@ -765,8 +761,3 @@ message :: InitFlags -> String -> IO ()
message (InitFlags{quiet = Flag True}) _ = return ()
message _ s = putStrLn s
#if MIN_VERSION_base(3,0,0)
#else
(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
f >=> g = \x -> f x >>= g
#endif
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Init.Heuristics
......@@ -34,9 +33,7 @@ import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )
import Control.Applicative ( pure, (<$>), (<*>) )
import Control.Monad (liftM )
import Data.Char ( isUpper, isLower, isSpace )
#if MIN_VERSION_base(3,0,3)
import Data.Either ( partitionEithers )
#endif
import Data.List ( isPrefixOf )
import Data.Maybe ( mapMaybe, catMaybes, maybeToList )
import Data.Monoid ( mempty, mappend )
......@@ -222,11 +219,3 @@ test db testProjectRoot = do
print $ knownCategories db
-}
#if MIN_VERSION_base(3,0,3)
#else
partitionEithers :: [Either a b] -> ([a],[b])
partitionEithers = foldr (either left right) ([],[])
where
left a (l, r) = (a:l, r)
right a (l, r) = (l, a:r)
#endif
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Init.Types
......@@ -153,12 +152,3 @@ instance Text Category where
disp = Disp.text . show
parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ]
#if MIN_VERSION_base(3,0,0)
#else
-- Compat instance for ghc-6.6 era
instance Monoid a => Monoid (Maybe a) where
mempty = Nothing
Nothing `mappend` m = m
m `mappend` Nothing = m
Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
#endif
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Install
......@@ -34,15 +33,10 @@ import Data.Maybe
( isJust, fromMaybe, maybeToList )
import Control.Exception as Exception
( bracket, handleJust )
#if MIN_VERSION_base(4,0,0)
import Control.Exception as Exception
( Exception(toException), catches, Handler(Handler), IOException )
import System.Exit
( ExitCode )
#else
import Control.Exception as Exception
( Exception(IOException, ExitException) )
#endif
import Distribution.Compat.Exception
( SomeException, catchIO, catchExit )
import Control.Monad
......@@ -657,11 +651,7 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
warn verbosity $ "Missing log file for build report: "
++ fromMaybe "" (ioeGetFileName ioe)
#if MIN_VERSION_base(4,0,0)
missingFile ioe
#else
missingFile (IOException ioe)
#endif
| isDoesNotExistError ioe = Just ioe
missingFile _ = Nothing
......@@ -1197,7 +1187,6 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
-- helper
onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult
onFailure result action =
#if MIN_VERSION_base(4,0,0)
action `catches`
[ Handler $ \ioe -> handler (ioe :: IOException)
, Handler $ \exit -> handler (exit :: ExitCode)
......@@ -1205,11 +1194,6 @@ onFailure result action =
where
handler :: Exception e => e -> IO BuildResult
handler = return . Left . result . toException
#else
action
`catchIO` (return . Left . result . IOException)
`catchExit` (return . Left . result . ExitException)
#endif
-- ------------------------------------------------------------
......
{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.InstallSymlink
......
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Win32SelfUpgrade
......
......@@ -18,7 +18,6 @@ module Distribution.Compat.Env (
lookupEnv, setEnv
) where
#ifdef __GLASGOW_HASKELL__
#ifdef mingw32_HOST_OS
import GHC.Windows
import Foreign.Safe
......@@ -37,14 +36,7 @@ import System.Environment (lookupEnv)
import Distribution.Compat.Exception (catchIO)
#endif
#if __GLASGOW_HASKELL__ > 611
import System.Posix.Internals ( withFilePath )
#endif /* __GLASGOW_HASKELL__ > 611 */
#if __GLASGOW_HASKELL__ <= 611
withFilePath :: FilePath -> (CString -> IO a) -> IO a
withFilePath = withCString
#endif /* __GLASGOW_HASKELL__ <= 611 */
#if !MIN_VERSION_base(4,6,0)
-- | @lookupEnv var@ returns the value of the environment variable @var@, or
......@@ -69,7 +61,6 @@ eRROR_ENVVAR_NOT_FOUND :: DWORD
eRROR_ENVVAR_NOT_FOUND = 203
#endif /* mingw32_HOST_OS */
#endif /* __GLASGOW_HASKELL__ */
-- | @setEnv name value@ sets the specified environment variable to @value@.
--
......@@ -86,7 +77,6 @@ setEnv key value_
value = takeWhile (/= '\NUL') value_
setEnv_ :: String -> String -> IO ()
#ifdef __GLASGOW_HASKELL__
#ifdef mingw32_HOST_OS
setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
......@@ -106,7 +96,3 @@ foreign import ccall unsafe "setenv"
c_setenv :: CString -> CString -> CInt -> IO CInt
#endif /* mingw32_HOST_OS */
#else
-- setEnv is a no-op on non-GHC compilers since we depend on GHC.Windows.
setEnv_ _key _value = return ()
#endif /* __GLASGOW_HASKELL__ */
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.Exception (
SomeException,
......@@ -14,43 +10,19 @@ module Distribution.Compat.Exception (
import System.Exit
import qualified Control.Exception as Exception
#if MIN_VERSION_base(4,0,0)
import Control.Exception (SomeException)
#else
import Control.Exception (Exception)
type SomeException = Exception
#endif
onException :: IO a -> IO b -> IO a
#if MIN_VERSION_base(4,0,0)
onException = Exception.onException
#else
onException io what = io `Exception.catch` \e -> do what
Exception.throw e
#endif
throwIOIO :: Exception.IOException -> IO a
#if MIN_VERSION_base(4,0,0)
throwIOIO = Exception.throwIO
#else
throwIOIO = Exception.throwIO . Exception.IOException
#endif
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
#if MIN_VERSION_base(4,0,0)
catchIO = Exception.catch
#else
catchIO = Exception.catchJust Exception.ioErrors
#endif
handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a
handleIO = flip catchIO
catchExit :: IO a -> (ExitCode -> IO a) -> IO a
#if MIN_VERSION_base(4,0,0)
catchExit = Exception.catch
#else
catchExit = Exception.catchJust exitExceptions
where exitExceptions (Exception.ExitException ee) = Just ee
exitExceptions _ = Nothing
#endif
......@@ -12,13 +12,8 @@ import System.Posix.Internals
( c_chmod )
import Foreign.C
( withCString )
#if MIN_VERSION_base(4,0,0)
import Foreign.C
( throwErrnoPathIfMinus1_ )
#else
import Foreign.C
( throwErrnoIfMinus1_ )
#endif
#endif /* mingw32_HOST_OS */
setFileOrdinary, setFileExecutable :: FilePath -> IO ()
......@@ -29,11 +24,7 @@ setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
setFileMode :: FilePath -> FileMode -> IO ()
setFileMode name m =
withCString name $ \s ->
#if __GLASGOW_HASKELL__ >= 608
throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
#else
throwErrnoIfMinus1_ name (c_chmod s m)
#endif
#else
setFileOrdinary _ = return ()
setFileExecutable _ = return ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment