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

5 files changed, 36 insertions, 27 deletions

diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index d0a38ec240..9523c08ff2 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -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
diff --git a/ghc/Main.hs b/ghc/Main.hs
index b720dea3db..276546bc95 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -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
diff --git a/libraries/ghc-boot/GHC/HandleEncoding.hs b/libraries/ghc-boot/GHC/HandleEncoding.hs
new file mode 100644
index 0000000000..aaa1689782
--- /dev/null
+++ b/libraries/ghc-boot/GHC/HandleEncoding.hs
@@ -0,0 +1,31 @@
+-- | 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 ()
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index 5c03a77043..0ca9c1ec73 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -40,6 +40,7 @@ Library
             GHC.PackageDb
             GHC.Serialized
             GHC.ForeignSrcLang
+            GHC.HandleEncoding
 
     build-depends: base       >= 4.7 && < 4.13,
                    binary     == 0.8.*,
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 0e793b4917..a32252139f 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -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