Commit 97cf1b28 authored by md9ms's avatar md9ms
Browse files

Fix Compat.H98 breakage, improve copyFile

I moved a lot of the ifdef:ing into the Compat.* modules, makes
a lot more sense.
parent 8e000329
{-# OPTIONS -cpp #-}
module Compat.Exception (bracket) where
#ifdef __NHC__
import System.IO.Error (catch, ioError)
#else
import Control.Exception (bracket)
#endif
#ifdef __NHC__
bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket before after thing
= do a <- before
r <- thing a `catch` \e -> do after a
ioError e
after a
return r
#endif
{-# OPTIONS_COMPILE -prelude #-}
module Compat.H98 where
{-# OPTIONS -cpp #-}
module Compat.H98 (Error(..)) where
#ifndef __NHC__
import Control.Monad.Error (Error(..))
#endif
#ifdef __NHC__
class Error e where
strMsg :: String -> e
......@@ -16,3 +21,4 @@ instance Error e => Monad (Either e) where
fail = Left . strMsg
Left e >>= f = Left e
Right x >>= f = f x
#endif
{-# OPTIONS -cpp #-}
module Compat.RawSystem (rawSystem) where
#ifndef __GLASGOW_HASKELL__
import Data.List (intersperse)
import System.Cmd (system)
import System.Exit (ExitCode)
#else
import System.Cmd (rawSystem)
#endif
#ifndef __GLASGOW_HASKELL__
rawSystem :: String -> [String] -> IO ExitCode
rawSystem p args = system $ concat $ intersperse " " (p : map esc args)
where esc arg = "\"" ++ arg ++ "\"" -- this is hideously broken, actually
#endif
......@@ -56,12 +56,6 @@ module Distribution.Package (
) where
import Control.Monad(foldM)
#ifdef __NHC__
-- nhc doesn't have C.M.Error (which defines Monad (Either String))
import Compat.H98
#else
import Control.Monad.Error
#endif
import Data.Char
import Data.List(isPrefixOf)
import Data.Maybe(fromMaybe)
......@@ -73,6 +67,7 @@ import Distribution.Setup(CompilerFlavor(..))
import System.IO(openFile, IOMode(..), hGetContents)
import Compat.H98
import Compat.ReadP
#ifdef DEBUG
......
......@@ -67,11 +67,7 @@ import System.Console.GetOpt
import System.Exit
import System.Environment
#ifdef __NHC__
import Compat.H98
#else
import Control.Monad.Error
#endif
import Compat.H98 ()
-- ------------------------------------------------------------
-- * Command Line Types and Exports
......
......@@ -71,16 +71,21 @@ import Distribution.Package (PackageDescription(..), showPackageId)
import Control.Monad(when, unless, liftM, mapM)
import Data.List(inits, nub, intersperse, findIndices, partition)
import Data.Maybe(Maybe, listToMaybe, isNothing, fromJust, catMaybes)
import System.IO (hPutStr, stderr)
import System.IO (hPutStr, stderr
#ifndef __NHC__
, openBinaryFile, IOMode(..), hGetBuf, hPutBuf, hClose
#endif
)
import System.IO.Error
import System.Exit
#ifdef __GLASGOW_HASKELL__
import System.Cmd (rawSystem)
#else
import Compat.RawSystem (rawSystem)
#endif
import Compat.Exception (bracket)
import System.Environment
import System.Directory
import Foreign.Marshal (allocaBytes)
#ifdef HAVE_UNIX_PACKAGE
import System.Posix.Files (getFileStatus, accessTime, modificationTime, setFileTimes)
#endif
#ifdef DEBUG
import HUnit ((~:), (~=?), Test(..), assertEqual)
......@@ -318,13 +323,32 @@ mkLibName pref lib = pathJoin [pref, ("libHS" ++ lib ++ ".a")]
pathJoin :: [String] -> FilePath
pathJoin = concat . intersperse pathSeparatorStr
-- |Preserves permissions, FIX: does not preserve dates
-- |Preserves permissions and, if possible, atime+mtime
copyFile :: FilePath -> FilePath -> IO ()
copyFile src dest
| dest == src = fail "copyFile: source and destination are the same file"
#ifdef __NHC__
| otherwise = do readFile src >>= writeFile dest
p <- getPermissions src
setPermissions dest p
try (getPermissions src >>= setPermissions dest)
return ()
#else
| otherwise = bracket (openBinaryFile src ReadMode) hClose $ \hSrc ->
bracket (openBinaryFile src WriteMode) hClose $ \hDest ->
do allocaBytes bufSize $ \buffer -> copyContents hSrc hDest buffer
try (getPermissions src >>= setPermissions dest)
#ifdef HAVE_UNIX_PACKAGE
try $ do st <- getFileStatus src
let atime = accessTime st
mtime = modificationTime st
setFileTimes dest atime mtime
#endif
return ()
where bufSize = 1024
copyContents hSrc hDest buffer
= do count <- hGetBuf hSrc buffer bufSize
when (count > 0) $ do hPutBuf hDest buffer count
copyContents hSrc hDest buffer
#endif
partitionIO :: (a -> IO Bool) -> [a] -> IO ([a], [a])
partitionIO f l
......
......@@ -17,8 +17,11 @@ setup:
mkdir -p dist/tmp
ghc $(GHCFLAGS) -odir dist/tmp -hidir dist/tmp Setup -o setup
Setup-nhc:
hmake -nhc98 -package base -prelude Setup
config: setup
./setup configure --prefix=$(PREF)
./setup configure --ghc --prefix=$(PREF)
build: build-stamp
build-stamp: config
......
......@@ -12,4 +12,4 @@ Modules: Distribution.Package, Distribution.Version,
Distribution.Simple.Register,
Distribution.Simple.GHCPackageConfig,
Distribution.GetOpt,
Compat.ReadP
\ No newline at end of file
Compat.ReadP, Compat.H98
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