Make the fileSystemEncoding/localeEncoding/foreignEncoding mutable

libraries/base/Foreign/C/String.hs

@@ -147,7 +147,7 @@ peekCString    :: CString -> IO String
 #ifndef __GLASGOW_HASKELL__
 peekCString = peekCAString
 #else
-peekCString = GHC.peekCString foreignEncoding
+peekCString s = getForeignEncoding >>= flip GHC.peekCString s
 #endif
 
 -- | Marshal a C string with explicit length into a Haskell string.
@@ -156,7 +156,7 @@ peekCStringLen           :: CStringLen -> IO String
 #ifndef __GLASGOW_HASKELL__
 peekCStringLen = peekCAStringLen
 #else
-peekCStringLen = GHC.peekCStringLen foreignEncoding
+peekCStringLen s = getForeignEncoding >>= flip GHC.peekCStringLen s
 #endif
 
 -- | Marshal a Haskell string into a NUL terminated C string.
@@ -171,7 +171,7 @@ newCString :: String -> IO CString
 #ifndef __GLASGOW_HASKELL__
 newCString = newCAString
 #else
-newCString = GHC.newCString foreignEncoding
+newCString s = getForeignEncoding >>= flip GHC.newCString s
 #endif
 
 -- | Marshal a Haskell string into a C string (ie, character array) with
@@ -185,7 +185,7 @@ newCStringLen     :: String -> IO CStringLen
 #ifndef __GLASGOW_HASKELL__
 newCStringLen = newCAStringLen
 #else
-newCStringLen = GHC.newCStringLen foreignEncoding
+newCStringLen s = getForeignEncoding >>= flip GHC.newCStringLen s
 #endif
 
 -- | Marshal a Haskell string into a NUL terminated C string using temporary
@@ -201,7 +201,7 @@ withCString :: String -> (CString -> IO a) -> IO a
 #ifndef __GLASGOW_HASKELL__
 withCString = withCAString
 #else
-withCString = GHC.withCString foreignEncoding
+withCString s f = getForeignEncoding >>= \enc -> GHC.withCString enc s f
 #endif
 
 -- | Marshal a Haskell string into a C string (ie, character array)
@@ -215,7 +215,7 @@ withCStringLen         :: String -> (CStringLen -> IO a) -> IO a
 #ifndef __GLASGOW_HASKELL__
 withCStringLen = withCAStringLen
 #else
-withCStringLen = GHC.withCStringLen foreignEncoding
+withCStringLen s f = getForeignEncoding >>= \enc -> GHC.withCStringLen enc s f
 #endif
 
 
@@ -230,7 +230,7 @@ charIsRepresentable c = return (ord c < 256)
 -- -- | Determines whether a character can be accurately encoded in a 'CString'.
 -- -- Unrepresentable characters are converted to '?' or their nearest visual equivalent.
 charIsRepresentable :: Char -> IO Bool
-charIsRepresentable = GHC.charIsRepresentable foreignEncoding
+charIsRepresentable c = getForeignEncoding >>= flip GHC.charIsRepresentable c
 #endif
 
 -- single byte characters

libraries/base/GHC/Environment.hs

@@ -45,7 +45,8 @@ getFullArgs =
    getFullProgArgv p_argc p_argv
    p    <- fromIntegral `liftM` peek p_argc
    argv <- peek p_argv
-   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding)
+   enc <- getFileSystemEncoding
+   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)
 
 foreign import ccall unsafe "getFullProgArgv"
     getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()

libraries/base/GHC/IO/Encoding.hs

@@ -22,7 +22,9 @@ module GHC.IO.Encoding (
         utf8, utf8_bom,
         utf16, utf16le, utf16be,
         utf32, utf32le, utf32be, 
-        localeEncoding, fileSystemEncoding, foreignEncoding,
+        initLocaleEncoding,
+        getLocaleEncoding, getFileSystemEncoding, getForeignEncoding,
+        setLocaleEncoding, setFileSystemEncoding, setForeignEncoding,
         char8,
         mkTextEncoding,
     ) where
@@ -45,6 +47,7 @@ import qualified GHC.IO.Encoding.UTF8   as UTF8
 import qualified GHC.IO.Encoding.UTF16  as UTF16
 import qualified GHC.IO.Encoding.UTF32  as UTF32
 
+import Data.IORef
 import Data.Char (toUpper)
 import Data.List
 import Data.Maybe
@@ -100,7 +103,7 @@ utf32be  :: TextEncoding
 utf32be = UTF32.utf32be
 
 -- | The Unicode encoding of the current locale
-localeEncoding :: TextEncoding
+getLocaleEncoding :: IO TextEncoding
 
 -- | The Unicode encoding of the current locale, but allowing arbitrary
 -- undecodable bytes to be round-tripped through it.
@@ -111,12 +114,24 @@ localeEncoding :: TextEncoding
 -- On Windows, this encoding *should not* be used if possible because
 -- the use of code pages is deprecated: Strings should be retrieved
 -- via the "wide" W-family of UTF-16 APIs instead
-fileSystemEncoding :: TextEncoding
+getFileSystemEncoding :: IO TextEncoding
 
 -- | The Unicode encoding of the current locale, but where undecodable
 -- bytes are replaced with their closest visual match. Used for
 -- the 'CString' marshalling functions in "Foreign.C.String"
-foreignEncoding :: TextEncoding
+getForeignEncoding :: IO TextEncoding
+
+setLocaleEncoding, setFileSystemEncoding, setForeignEncoding :: TextEncoding -> IO ()
+(getLocaleEncoding, setLocaleEncoding)         = mkGlobal initLocaleEncoding
+(getFileSystemEncoding, setFileSystemEncoding) = mkGlobal initFileSystemEncoding
+(getForeignEncoding, setForeignEncoding)       = mkGlobal initForeignEncoding
+
+mkGlobal :: a -> (IO a, a -> IO ())
+mkGlobal x = unsafePerformIO $ do
+    x_ref <- newIORef x
+    return (readIORef x_ref, writeIORef x_ref)
+
+initLocaleEncoding, initFileSystemEncoding, initForeignEncoding :: TextEncoding
 
 #if !defined(mingw32_HOST_OS)
 -- It is rather important that we don't just call Iconv.mkIconvEncoding here
@@ -129,13 +144,13 @@ foreignEncoding :: TextEncoding
 -- FIXME: this is not a complete solution because if the locale encoding is one
 -- which we don't have a Haskell-side decoder for, iconv might still ignore the
 -- lone surrogate in the input.
-localeEncoding     = unsafePerformIO $ mkTextEncoding' ErrorOnCodingFailure Iconv.localeEncodingName
-fileSystemEncoding = unsafePerformIO $ mkTextEncoding' RoundtripFailure     Iconv.localeEncodingName
-foreignEncoding    = unsafePerformIO $ mkTextEncoding' IgnoreCodingFailure  Iconv.localeEncodingName
+initLocaleEncoding     = unsafePerformIO $ mkTextEncoding' ErrorOnCodingFailure Iconv.localeEncodingName
+initFileSystemEncoding = unsafePerformIO $ mkTextEncoding' RoundtripFailure     Iconv.localeEncodingName
+initForeignEncoding    = unsafePerformIO $ mkTextEncoding' IgnoreCodingFailure  Iconv.localeEncodingName
 #else
-localeEncoding     = CodePage.localeEncoding
-fileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure
-foreignEncoding    = CodePage.mkLocaleEncoding IgnoreCodingFailure
+initLocaleEncoding     = CodePage.localeEncoding
+initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure
+initForeignEncoding    = CodePage.mkLocaleEncoding IgnoreCodingFailure
 #endif
 
 -- | An encoding in which Unicode code points are translated to bytes

libraries/base/GHC/IO/Encoding.hs-boot

@@ -3,7 +3,8 @@
 
 module GHC.IO.Encoding where
 
+import GHC.IO (IO)
 import GHC.IO.Encoding.Types
 
-localeEncoding, fileSystemEncoding, foreignEncoding :: TextEncoding
+getLocaleEncoding, getFileSystemEncoding, getForeignEncoding :: IO TextEncoding
 

libraries/base/GHC/IO/Handle.hs

@@ -562,8 +562,8 @@ hSetBinaryMode handle bin =
          flushCharBuffer h_
          closeTextCodecs h_
 
-         let mb_te | bin       = Nothing
-                   | otherwise = Just localeEncoding
+         mb_te <- if bin then return Nothing
+                         else fmap Just getLocaleEncoding
 
          openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do
 
@@ -639,7 +639,7 @@ dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
            -> IO Handle
 dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
    -- XXX wrong!
-  let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing
+  mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing
   mkHandle new_dev filepath haType True{-buffered-} mb_codec
       NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
       mb_finalizer other_side

libraries/base/GHC/IO/Handle/FD.hs

@@ -52,7 +52,8 @@ stdin :: Handle
 stdin = unsafePerformIO $ do
    -- ToDo: acquire lock
    setBinaryMode FD.stdin
-   mkHandle FD.stdin "<stdin>" ReadHandle True (Just localeEncoding)
+   enc <- getLocaleEncoding
+   mkHandle FD.stdin "<stdin>" ReadHandle True (Just enc)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
 
@@ -62,7 +63,8 @@ stdout :: Handle
 stdout = unsafePerformIO $ do
    -- ToDo: acquire lock
    setBinaryMode FD.stdout
-   mkHandle FD.stdout "<stdout>" WriteHandle True (Just localeEncoding)
+   enc <- getLocaleEncoding
+   mkHandle FD.stdout "<stdout>" WriteHandle True (Just enc)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
 
@@ -72,8 +74,9 @@ stderr :: Handle
 stderr = unsafePerformIO $ do
     -- ToDo: acquire lock
    setBinaryMode FD.stderr
+   enc <- getLocaleEncoding
    mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-} 
-                (Just localeEncoding)
+                (Just enc)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
 
@@ -179,7 +182,7 @@ openFile' filepath iomode binary non_blocking = do
   -- first open the file to get an FD
   (fd, fd_type) <- FD.openFile filepath iomode non_blocking
 
-  let mb_codec = if binary then Nothing else Just localeEncoding
+  mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding
 
   -- then use it to make a Handle
   mkHandleFromFD fd fd_type filepath iomode
@@ -253,8 +256,8 @@ fdToHandle' fdint mb_type is_socket filepath iomode binary = do
   (fd,fd_type) <- FD.mkFD fdint iomode mb_stat
                        is_socket
                        is_socket
-  mkHandleFromFD fd fd_type filepath iomode is_socket
-                       (if binary then Nothing else Just localeEncoding)
+  enc <- if binary then return Nothing else fmap Just getLocaleEncoding
+  mkHandleFromFD fd fd_type filepath iomode is_socket enc
 
 
 -- | Turn an existing file descriptor into a Handle.  This is used by

libraries/base/System/Environment.hs

@@ -37,7 +37,7 @@ import Foreign.C
 import Control.Exception.Base   ( bracket )
 -- import GHC.IO
 import GHC.IO.Exception
-import GHC.IO.Encoding (fileSystemEncoding)
+import GHC.IO.Encoding (getFileSystemEncoding)
 import qualified GHC.Foreign as GHC
 import Data.List
 #ifdef mingw32_HOST_OS
@@ -127,7 +127,8 @@ getArgs =
    getProgArgv p_argc p_argv
    p    <- fromIntegral `liftM` peek p_argc
    argv <- peek p_argv
-   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding)
+   enc <- getFileSystemEncoding
+   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)
 
 foreign import ccall unsafe "getProgArgv"
   getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
@@ -157,7 +158,8 @@ getProgName =
 
 unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
 unpackProgName argv = do
-  s <- peekElemOff argv 0 >>= GHC.peekCString fileSystemEncoding
+  enc <- getFileSystemEncoding
+  s <- peekElemOff argv 0 >>= GHC.peekCString enc
   return (basename s)
 #endif
 
@@ -213,7 +215,7 @@ getEnv name =
     withCString name $ \s -> do
       litstring <- c_getenv s
       if litstring /= nullPtr
-        then GHC.peekCString fileSystemEncoding litstring
+        then getFileSystemEncoding >>= \enc -> GHC.peekCString enc litstring
         else ioe_missingEnvVar name
 
 foreign import ccall unsafe "getenv"
@@ -273,7 +275,8 @@ freeProgArgv argv = do
 
 setProgArgv :: [String] -> IO (Ptr CString)
 setProgArgv argv = do
-  vs <- mapM (GHC.newCString fileSystemEncoding) argv >>= newArray0 nullPtr
+  enc <- getFileSystemEncoding
+  vs <- mapM (GHC.newCString enc) argv >>= newArray0 nullPtr
   c_setProgArgv (genericLength argv) vs
   return vs
 
@@ -323,7 +326,8 @@ getEnvironment = do
    pBlock <- getEnvBlock
    if pBlock == nullPtr then return []
     else do
-      stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString fileSystemEncoding)
+      enc <- getFileSystemEncoding
+      stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)
       return (map divvy stuff)
 
 foreign import ccall unsafe "__hscore_environ" 

libraries/base/System/IO.hs

@@ -413,6 +413,13 @@ readIO s        =  case (do { (x,t) <- reads s ;
                         [x]    -> return x
                         []     -> ioError (userError "Prelude.readIO: no parse")
                         _      -> ioError (userError "Prelude.readIO: ambiguous parse")
+
+-- | The Unicode encoding of the current locale
+--
+-- This is the initial locale encoding: if it has been subsequently changed by
+-- 'GHC.IO.Encoding.setLocaleEncoding' this value will not reflect that change.
+localeEncoding :: TextEncoding
+localeEncoding = initLocaleEncoding
 #endif  /* __GLASGOW_HASKELL__ */
 
 #ifndef __NHC__
@@ -584,8 +591,8 @@ openTempFile' loc tmp_dir template binary mode = do
                               False{-is_socket-} 
                               True{-is_nonblock-}
 
-         h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-}
-                           (Just localeEncoding)
+         enc <- getLocaleEncoding
+         h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc)
 
          return (filepath, h)
 #else

libraries/base/System/Posix/Internals.hs

@@ -53,7 +53,7 @@ import GHC.IO.IOMode
 import GHC.IO.Exception
 import GHC.IO.Device
 #ifndef mingw32_HOST_OS
-import {-# SOURCE #-} GHC.IO.Encoding (fileSystemEncoding)
+import {-# SOURCE #-} GHC.IO.Encoding (getFileSystemEncoding)
 import qualified GHC.Foreign as GHC
 #endif
 #elif __HUGS__
@@ -199,9 +199,9 @@ peekFilePath :: CString -> IO FilePath
 peekFilePathLen :: CStringLen -> IO FilePath
 
 #if __GLASGOW_HASKELL__
-withFilePath = GHC.withCString fileSystemEncoding
-peekFilePath = GHC.peekCString fileSystemEncoding
-peekFilePathLen = GHC.peekCStringLen fileSystemEncoding
+withFilePath fp f = getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f
+peekFilePath fp = getFileSystemEncoding >>= \enc -> GHC.peekCString enc fp
+peekFilePathLen fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp
 #else
 withFilePath = withCString
 peekFilePath = peekCString