Commit c99ac791 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Revert some of the UTF8 changes, use UTF8 only for files we know are UTF8

So we use ordinary read/writeFile for ordinary text files. For console
output we use ordinary putStr etc and we'll just hope that haskell
implementations catch up and deal with that sensibly. Don't assume
captured program output is UTF8, use the default encoding.
So we use binary mode IO along with UTF8 encoding and decoding only for 
file types that we specify to be UTF8, which are .cabal files and
.hs/.lhs files only.
parent 8c5ca96a
......@@ -3,10 +3,11 @@
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
-- #hide
module Distribution.Compat.TempFile (openTempFile) where
module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile) where
#if __NHC__ || __HUGS__
import System.IO (openFile, Handle, IOMode(ReadWriteMode))
import System.IO (openFile, openBinaryFile,
Handle, IOMode(ReadWriteMode))
import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>), splitExtension)
#if __NHC__
......@@ -16,7 +17,7 @@ foreign import ccall unsafe "getpid" c_getpid :: IO CPid
import System.Posix.Internals (c_getpid)
#endif
#else
import System.IO (openTempFile)
import System.IO (openTempFile, openBinaryTempFile)
#endif
-- ------------------------------------------------------------
......@@ -44,6 +45,20 @@ openTempFile tmp_dir template
else do hnd <- openFile path ReadWriteMode
return (path, hnd)
getProcessID :: IO Int
getProcessID = fmap fromIntegral c_getpid
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)
getProcessID :: IO Int
getProcessID = fmap fromIntegral c_getpid
#endif
......@@ -76,7 +76,7 @@ import Distribution.Verbosity (Verbosity)
import Distribution.Compiler (CompilerFlavor(..))
import Distribution.PackageDescription.Configuration (parseCondition, freeVars)
import Distribution.Simple.Utils
( die, dieWithLocation, warn, intercalate, readTextFile, writeTextFile )
( die, dieWithLocation, warn, intercalate, readUTF8File, writeUTF8File )
-- -----------------------------------------------------------------------------
......@@ -282,11 +282,14 @@ flagFieldDescrs =
-- | Given a parser and a filename, return the parse of the file,
-- after checking if the file exists.
readAndParseFile :: Verbosity -> (String -> ParseResult a) -> FilePath -> IO a
readAndParseFile verbosity parser fpath = do
readAndParseFile :: (FilePath -> IO String)
-> (String -> ParseResult a)
-> Verbosity
-> FilePath -> IO a
readAndParseFile readFile' parser verbosity fpath = do
exists <- doesFileExist fpath
when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
str <- readTextFile fpath
str <- readFile' fpath
case parser str of
ParseFailed e -> do
let (line, message) = locatedErrorMsg e
......@@ -296,12 +299,13 @@ readAndParseFile verbosity parser fpath = do
return x
readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
readHookedBuildInfo verbosity = readAndParseFile verbosity parseHookedBuildInfo
readHookedBuildInfo =
readAndParseFile readFile parseHookedBuildInfo
-- |Parse the given package file.
readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readPackageDescription verbosity =
readAndParseFile verbosity parsePackageDescription
readPackageDescription =
readAndParseFile readUTF8File parsePackageDescription
stanzas :: [Field] -> [[Field]]
stanzas [] = []
......@@ -709,7 +713,7 @@ parseHookedBuildInfo inp = do
-- Pretty printing
writePackageDescription :: FilePath -> PackageDescription -> IO ()
writePackageDescription fpath pkg = writeTextFile fpath (showPackageDescription pkg)
writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
showPackageDescription :: PackageDescription -> String
showPackageDescription pkg = render $
......@@ -729,7 +733,7 @@ ppCustomField :: (String,String) -> Doc
ppCustomField (name,val) = text name <> colon <+> showFreeText val
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
writeHookedBuildInfo fpath pbi = writeTextFile fpath (showHookedBuildInfo pbi)
writeHookedBuildInfo fpath pbi = writeFile fpath (showHookedBuildInfo pbi)
showHookedBuildInfo :: HookedBuildInfo -> String
showHookedBuildInfo (mb_lib_bi, ex_bi) = render $
......
......@@ -61,7 +61,7 @@ import Distribution.Simple.BuildPaths ( autogenModuleName )
import Distribution.Simple.Configure
( localBuildInfoFile )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, die, setupMessage, writeTextFile )
( createDirectoryIfMissingVerbose, die, setupMessage, writeUTF8File )
import Distribution.System
import System.FilePath ( (</>), pathSeparator )
......@@ -217,7 +217,7 @@ buildPathsModule pkg_descr lbi =
then getModificationTime paths_filepath
else return btime
if btime >= ptime
then writeTextFile paths_filepath (header++body)
then writeUTF8File paths_filepath (header++body)
else return ()
where
InstallDirs {
......
......@@ -94,7 +94,7 @@ import Distribution.Simple.BuildPaths
( distPref )
import Distribution.Simple.Utils
( die, warn, info, setupMessage, createDirectoryIfMissingVerbose
, intercalate, comparing, readTextFile, writeTextFile )
, intercalate, comparing )
import Distribution.Simple.Register
( removeInstalledConfig )
import Distribution.System
......@@ -143,7 +143,7 @@ tryGetConfigStateFile filename = do
let dieMsg = "error reading " ++ filename ++
"; run \"setup configure\" command?\n"
if (not e) then return $ Left dieMsg else do
str <- readTextFile filename
str <- readFile filename
case reads str of
[(bi,_)] -> return $ Right bi
_ -> return $ Left dieMsg
......@@ -171,7 +171,7 @@ maybeGetPersistBuildConfig = do
writePersistBuildConfig :: LocalBuildInfo -> IO ()
writePersistBuildConfig lbi = do
createDirectoryIfMissing False distPref
writeTextFile localBuildInfoFile (show lbi)
writeFile localBuildInfoFile (show lbi)
-- |Check that localBuildInfoFile is up-to-date with respect to the
-- .cabal file.
......
......@@ -309,7 +309,7 @@ getInstalledPackages' verbosity packagedbs conf = do
(UserPackageDB, _global:_) -> Nothing
(SpecificPackageDB specific, _) -> Just specific
_ -> error "cannot read ghc-pkg global package file"
sequence [ readAsciiFile file >>= \content -> return (db, read content)
sequence [ readFile file >>= \content -> return (db, read content)
| (db , Just file) <- zip packagedbs (map dbFile packagedbs) ]
-- -----------------------------------------------------------------------------
......
......@@ -190,7 +190,6 @@ haddock pkg_descr lbi suffixes flags = do
subtitle | null (synopsis pkg_descr) = ""
| otherwise = ": " ++ synopsis pkg_descr
withTempFile distPref template $ \prologFileName prologFileHandle -> do
--TODO: what format is this? utf8 or ascii?
hPutStrLn prologFileHandle prolog
hClose prologFileHandle
let targets
......
......@@ -61,7 +61,7 @@ import Distribution.Simple.BuildPaths
( autogenModuleName, autogenModulesDir,
dllExtension )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, readTextFile, writeTextFile
( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File
, findFile, dotToSep, findFileWithExtension, smartCopySources
, die, info, notice )
import Language.Haskell.Extension
......@@ -251,7 +251,7 @@ build pkg_descr lbi verbosity = do
-- Get the non-literate source of a Haskell module.
readHaskellFile :: FilePath -> IO String
readHaskellFile file = do
text <- readTextFile file
text <- readUTF8File file
if ".lhs" `isSuffixOf` file
then either return die (unlit file text)
else return text
......@@ -269,7 +269,7 @@ getOptionsFromSource
[String] -- INCLUDE pragmas
)
getOptionsFromSource file = do
text <- readTextFile file
text <- readUTF8File file
text' <- if ".lhs" `isSuffixOf` file
then either return die (unlit file text)
else return text
......@@ -383,7 +383,7 @@ install verbosity libDir installProgDir binDir targetProgDir buildPref (progpref
let args = hugsOptions ++ [targetName, "\"$@\""]
in unlines ["#! /bin/sh",
unwords ("runhugs" : args)]
writeTextFile exeFile script
writeFile exeFile script
perms <- getPermissions exeFile
setPermissions exeFile perms { executable = True, readable = True }
......
......@@ -70,7 +70,7 @@ import Distribution.Version ( VersionRange(AnyVersion) )
import Distribution.Package ( PackageIdentifier(..), showPackageId,
parsePackageId, Package(..) )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, copyFileVerbose, writeTextFile
( createDirectoryIfMissingVerbose, copyFileVerbose
, die, info, intercalate )
import System.FilePath ( (</>) )
import Distribution.Verbosity
......@@ -140,7 +140,7 @@ build pkg_descr lbi verbosity = do
let pkgid = showPackageId (packageId pkg_descr)
pfile = buildDir lbi </> "jhc-pkg.conf"
hlfile= buildDir lbi </> (pkgid ++ ".hl")
writeTextFile pfile $ jhcPkgConf pkg_descr
writeFile pfile $ jhcPkgConf pkg_descr
rawSystemProgram verbosity jhcProg ["--build-hl="++pfile, "-o", hlfile]
withExe pkg_descr $ \exe -> do
info verbosity ("Building executable "++exeName exe)
......
......@@ -63,7 +63,7 @@ import Distribution.Package (showPackageId, Package(..))
import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..), compilerVersion)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, readTextFile, writeTextFile
( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File
, die, setupMessage
, findFileWithExtension, findFileWithExtension', dotToSep )
import Distribution.Simple.Program (Program(..), ConfiguredProgram(..),
......@@ -270,8 +270,8 @@ ppUnlit =
PreProcessor {
platformIndependent = True,
runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> do
contents <- readTextFile inFile
either (writeTextFile outFile) die (unlit inFile contents)
contents <- readUTF8File inFile
either (writeUTF8File outFile) die (unlit inFile contents)
}
ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor
......
......@@ -68,7 +68,7 @@ import Distribution.InstalledPackageInfo
emptyInstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, copyFileVerbose, writeTextFile
( createDirectoryIfMissingVerbose, copyFileVerbose, writeUTF8File
, die, info, notice, setupMessage )
import Distribution.System
......@@ -172,7 +172,7 @@ writeInstalledConfig pkg_descr lbi inplace instConfOverride = do
let instConfDefault | inplace = inplacePkgConfigFile
| otherwise = installedPkgConfigFile
instConf = fromMaybe instConfDefault instConfOverride
writeTextFile instConf (pkg_config ++ "\n")
writeUTF8File instConf (pkg_config ++ "\n")
-- |Create a string suitable for writing out to the package config file
showInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool
......@@ -310,8 +310,8 @@ rawSystemEmit :: ConfiguredProgram -- ^Program to run
rawSystemEmit prog scriptName extraArgs
= case os of
Windows _ ->
writeTextFile scriptName ("@" ++ path ++ concatMap (' ':) args)
_ -> do writeTextFile scriptName ("#!/bin/sh\n\n"
writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
_ -> do writeFile scriptName ("#!/bin/sh\n\n"
++ (path ++ concatMap (' ':) args)
++ "\n")
p <- getPermissions scriptName
......@@ -328,8 +328,8 @@ rawSystemPipe :: ConfiguredProgram
rawSystemPipe prog scriptName pipeFrom extraArgs
= case os of
Windows _ ->
writeTextFile scriptName ("@" ++ path ++ concatMap (' ':) args)
_ -> do writeTextFile scriptName ("#!/bin/sh\n\n"
writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
_ -> do writeFile scriptName ("#!/bin/sh\n\n"
++ "echo '" ++ escapeForShell pipeFrom
++ "' | "
++ (path ++ concatMap (' ':) args)
......
......@@ -99,7 +99,7 @@ setupWrapper args mdir = inDir mdir $ do
then mainAction args -- current version is OK, so no need
-- to compile a special Setup.hs.
else do createDirectoryIfMissingVerbose verbosity True setupDir
writeTextFile setupHs mainText
writeUTF8File setupHs mainText
trySetupScript setupHs $ error "panic! shouldn't happen"
Nothing ->
trySetupScript "Setup.hs" $
......
......@@ -60,7 +60,7 @@ import Distribution.PackageDescription.Check
import Distribution.Package (showPackageId, PackageIdentifier(pkgVersion), Package(..))
import Distribution.Version (Version(versionBranch), VersionRange(AnyVersion))
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, readTextFile, writeTextFile
( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File
, copyFiles, copyFileVerbose, findFile, findFileWithExtension, dotToSep
, die, warn, notice, setupMessage, defaultPackageDesc )
import Distribution.Simple.Setup (SDistFlags(..), fromFlag)
......@@ -168,7 +168,7 @@ prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date = do
lhsExists <- doesFileExist "Setup.lhs"
if hsExists then copyFileTo verbosity targetDir "Setup.hs"
else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"
else writeTextFile (targetDir </> "Setup.hs") $ unlines [
else writeUTF8File (targetDir </> "Setup.hs") $ unlines [
"import Distribution.Simple",
"main = defaultMainWithHooks defaultUserHooks"]
-- the description file itself
......@@ -177,8 +177,8 @@ prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date = do
-- We could just writePackageDescription targetDescFile pkg_descr,
-- but that would lose comments and formatting.
if snapshot then do
contents <- readTextFile descFile
writeTextFile targetDescFile $
contents <- readUTF8File descFile
writeUTF8File targetDescFile $
unlines $ map (appendVersion date) $ lines $ contents
else copyFileVerbose verbosity descFile targetDescFile
return targetDir
......
......@@ -79,7 +79,6 @@ module Distribution.Simple.Utils (
-- * files
withTempFile,
writeFileAtomic,
-- * .cabal and .buildinfo files
defaultPackageDesc,
......@@ -90,9 +89,8 @@ module Distribution.Simple.Utils (
-- * Unicode
fromUTF8,
toUTF8,
readTextFile,
readAsciiFile,
writeTextFile,
readUTF8File,
writeUTF8File,
-- * generic utils
equating,
......@@ -126,7 +124,8 @@ import System.FilePath
import System.Directory
( copyFile, createDirectoryIfMissing, renameFile )
import System.IO
( hPutStrLn, hPutStr, hClose , stderr, hFlush, stdout )
( openBinaryFile, IOMode(ReadMode), stderr, stdout
, hPutStrLn, hPutStr, hFlush, hClose )
import System.IO.Error as IO.Error
( try )
import qualified Control.Exception as Exception
......@@ -148,7 +147,7 @@ import System.Directory (getTemporaryDirectory)
#endif
import System.IO (Handle)
import Distribution.Compat.TempFile (openTempFile)
import Distribution.Compat.TempFile (openTempFile, openBinaryTempFile)
import Distribution.Verbosity
-- We only get our own version number when we're building with ourselves
......@@ -169,7 +168,7 @@ die :: String -> IO a
die msg = do
hFlush stdout
pname <- getProgName
hPutStrLn stderr $ toUTF8 (pname ++ ": " ++ msg)
hPutStrLn stderr (pname ++ ": " ++ msg)
exitWith (ExitFailure 1)
-- | Non fatal conditions that may be indicative of an error or problem.
......@@ -180,7 +179,7 @@ warn :: Verbosity -> String -> IO ()
warn verbosity msg =
when (verbosity >= normal) $ do
hFlush stdout
hPutStrLn stderr ("Warning: " ++ toUTF8 msg)
hPutStrLn stderr ("Warning: " ++ msg)
-- | Useful status messages.
--
......@@ -192,7 +191,7 @@ warn verbosity msg =
notice :: Verbosity -> String -> IO ()
notice verbosity msg =
when (verbosity >= normal) $
putStrLn (toUTF8 msg)
putStrLn msg
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage verbosity msg pkgid =
......@@ -205,7 +204,7 @@ setupMessage verbosity msg pkgid =
info :: Verbosity -> String -> IO ()
info verbosity msg =
when (verbosity >= verbose) $
putStrLn (toUTF8 msg)
putStrLn msg
-- | Detailed internal debugging information
--
......@@ -214,7 +213,7 @@ info verbosity msg =
debug :: Verbosity -> String -> IO ()
debug verbosity msg =
when (verbosity >= deafening) $
putStrLn (toUTF8 msg)
putStrLn msg
-- | Perform an IO action, catching any IO exceptions and printing an error
-- if one occurs.
......@@ -223,7 +222,7 @@ chattyTry :: String -- ^ a description of the action we were attempting
-> IO ()
chattyTry desc action =
Exception.catch action $ \exception ->
putStrLn $ toUTF8 $ "Error while " ++ desc ++ ": " ++ show exception
putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
-- -----------------------------------------------------------------------------
-- Helper functions
......@@ -301,7 +300,7 @@ rawSystemStdout' verbosity path args = do
forkIO $ do evaluate (length err); return ()
-- wait for all the output
output <- fromUTF8 `fmap` hGetContents outh
output <- hGetContents outh
evaluate (length output)
-- wait for the program to terminate
......@@ -314,7 +313,7 @@ rawSystemStdout' verbosity path args = do
hClose tmpHandle
let quote name = "'" ++ name ++ "'"
exitCode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName
output <- readTextFile tmpName
output <- readFile tmpName
length output `seq` return (output, exitCode)
#endif
......@@ -514,7 +513,7 @@ withTempFile tmpDir template action =
writeFileAtomic :: FilePath -> String -> IO ()
writeFileAtomic targetFile content = do
Exception.bracketOnError
(openTempFile targetDir template)
(openBinaryTempFile targetDir template)
(\(tmpFile, tmpHandle) -> IO.Error.try (hClose tmpHandle)
>> IO.Error.try (removeFile tmpFile))
$ \(tmpFile, tmpHandle) -> do
......@@ -645,22 +644,15 @@ toUTF8 (c:cs)
--
-- Reads lazily using ordinary 'readFile'.
--
readTextFile :: FilePath -> IO String
readTextFile = fmap fromUTF8 . readFile
-- | Reads an ASCII encoded text file as a String
--
-- Reads lazily using ordinary 'readFile'.
--
readAsciiFile :: FilePath -> IO String
readAsciiFile = readFile
readUTF8File :: FilePath -> IO String
readUTF8File f = fmap fromUTF8 . hGetContents =<< openBinaryFile f ReadMode
-- | Writes a Unicode String as a UTF8 encoded text file.
--
-- Uses 'writeFileAtomic', so provides the same guarantees.
--
writeTextFile :: FilePath -> String -> IO ()
writeTextFile path = writeFileAtomic path . toUTF8
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File path = writeFileAtomic path . toUTF8
-- ------------------------------------------------------------
-- * Common utils
......
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