Commit cf88c2b1 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

ghc-pkg: Configure handle encodings

This fixes #15021 using a the same approach as was used to fix the issue
in ghc (#10762).

Test Plan: Validate on Windows as user whose username contains
non-ASCII characters

Reviewers: simonmar

Reviewed By: simonmar

Subscribers: lehins, thomie, carter

GHC Trac Issues: #15021

Differential Revision: https://phabricator.haskell.org/D4642
parent 21e1a00c
......@@ -98,7 +98,6 @@ module Util (
doesDirNameExist,
getModificationUTCTime,
modificationTimeIfExists,
hSetTranslit,
global, consIORef, globalM,
sharedGlobal, sharedGlobalM,
......@@ -145,9 +144,7 @@ import GHC.Stack (HasCallStack)
import Control.Applicative ( liftA2 )
import Control.Monad ( liftM, guard )
import GHC.IO.Encoding (mkTextEncoding, textEncodingName)
import GHC.Conc.Sync ( sharedCAF )
import System.IO (Handle, hGetEncoding, hSetEncoding)
import System.IO.Error as IO ( isDoesNotExistError )
import System.Directory ( doesDirectoryExist, getModificationTime )
import System.FilePath
......@@ -1256,18 +1253,6 @@ modificationTimeIfExists f = do
else ioError e
-- --------------------------------------------------------------
-- Change the character encoding of the given Handle to transliterate
-- on unsupported characters instead of throwing an exception
hSetTranslit :: Handle -> IO ()
hSetTranslit h = do
menc <- hGetEncoding h
case fmap textEncodingName menc of
Just name | '/' `notElem` name -> do
enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
hSetEncoding h enc'
_ -> return ()
-- split a string at the last character where 'pred' is True,
-- returning a pair of strings. The first component holds the string
-- up (but not including) the last character for which 'pred' returned
......
......@@ -40,6 +40,7 @@ import Module ( ModuleName )
-- Various other random stuff that we need
import GHC.HandleEncoding
import Config
import Constants
import HscTypes
......@@ -92,18 +93,7 @@ main = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
-- Handle GHC-specific character encoding flags, allowing us to control how
-- GHC produces output regardless of OS.
env <- getEnvironment
case lookup "GHC_CHARENC" env of
Just "UTF-8" -> do
hSetEncoding stdout utf8
hSetEncoding stderr utf8
_ -> do
-- Avoid GHC erroring out when trying to display unhandled characters
hSetTranslit stdout
hSetTranslit stderr
configureHandleEncoding
GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
-- 1. extract the -B flag from the args
argv0 <- getArgs
......
-- | See GHC #10762 and #15021.
module GHC.HandleEncoding (configureHandleEncoding) where
import GHC.IO.Encoding (textEncodingName)
import System.Environment
import System.IO
-- | Handle GHC-specific character encoding flags, allowing us to control how
-- GHC produces output regardless of OS.
configureHandleEncoding :: IO ()
configureHandleEncoding = do
env <- getEnvironment
case lookup "GHC_CHARENC" env of
Just "UTF-8" -> do
hSetEncoding stdout utf8
hSetEncoding stderr utf8
_ -> do
-- Avoid GHC erroring out when trying to display unhandled characters
hSetTranslit stdout
hSetTranslit stderr
-- | Change the character encoding of the given Handle to transliterate
-- on unsupported characters instead of throwing an exception
hSetTranslit :: Handle -> IO ()
hSetTranslit h = do
menc <- hGetEncoding h
case fmap textEncodingName menc of
Just name | '/' `notElem` name -> do
enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
hSetEncoding h enc'
_ -> return ()
......@@ -40,6 +40,7 @@ Library
GHC.PackageDb
GHC.Serialized
GHC.ForeignSrcLang
GHC.HandleEncoding
build-depends: base >= 4.7 && < 4.13,
binary == 0.8.*,
......
......@@ -30,6 +30,7 @@ module Main (main) where
import Version ( version, targetOS, targetARCH )
import qualified GHC.PackageDb as GhcPkg
import GHC.PackageDb (BinaryStringRep(..))
import GHC.HandleEncoding
import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Data.Graph as Graph
import qualified Distribution.ModuleName as ModuleName
......@@ -120,6 +121,7 @@ anyM p (x:xs) = do
main :: IO ()
main = do
configureHandleEncoding
args <- getArgs
case getOpt Permute (flags ++ deprecFlags) args of
......
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