update to current master againwip/T13904

4 files changed, 57 insertions, 36 deletions

diff --git a/libraries/ghc-boot/GHC/HandleEncoding.hs b/libraries/ghc-boot/GHC/HandleEncoding.hs
new file mode 100644
index 0000000000..3c4c10c70f
--- /dev/null
+++ b/libraries/ghc-boot/GHC/HandleEncoding.hs
@@ -0,0 +1,32 @@
+-- | See GHC #10762 and #15021.
+module GHC.HandleEncoding (configureHandleEncoding) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+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/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs
index bf83d25baa..5de3a5fc74 100644
--- a/libraries/ghc-boot/GHC/PackageDb.hs
+++ b/libraries/ghc-boot/GHC/PackageDb.hs
@@ -64,6 +64,7 @@ module GHC.PackageDb (
        writePackageDb
   ) where
 
+import Prelude -- See note [Why do we import Prelude here?]
 import Data.Version (Version(..))
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS.Char8
@@ -80,9 +81,7 @@ import System.FilePath
 import System.IO
 import System.IO.Error
 import GHC.IO.Exception (IOErrorType(InappropriateType))
-#if MIN_VERSION_base(4,10,0)
 import GHC.IO.Handle.Lock
-#endif
 import System.Directory
 
 
@@ -209,12 +208,7 @@ emptyInstalledPackageInfo =
   }
 
 -- | Represents a lock of a package db.
-newtype PackageDbLock = PackageDbLock
-#if MIN_VERSION_base(4,10,0)
-  Handle
-#else
-  ()  -- no locking primitives available in base < 4.10
-#endif
+newtype PackageDbLock = PackageDbLock Handle
 
 -- | Acquire an exclusive lock related to package DB under given location.
 lockPackageDb :: FilePath -> IO PackageDbLock
@@ -222,8 +216,6 @@ lockPackageDb :: FilePath -> IO PackageDbLock
 -- | Release the lock related to package DB.
 unlockPackageDb :: PackageDbLock -> IO ()
 
-#if MIN_VERSION_base(4,10,0)
-
 -- | Acquire a lock of given type related to package DB under given location.
 lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock
 lockPackageDbWith mode file = do
@@ -239,15 +231,21 @@ lockPackageDbWith mode file = do
   -- DB for reading then we will require that the installer/packaging has
   -- included the lock file.
   --
-  -- Thus the logic here is to first try opening in read-only mode (to handle
-  -- global read-only DBs) and if the file does not exist then try opening in
-  -- read/write mode to create the lock file. If either succeed then lock the
-  -- file. IO exceptions (other than the first open attempt failing due to the
-  -- file not existing) simply propagate.
+  -- Thus the logic here is to first try opening in read-write mode
+  -- and if that fails we try read-only (to handle global read-only DBs).
+  -- If either succeed then lock the file. IO exceptions (other than the first
+  -- open attempt failing due to the file not existing) simply propagate.
+  --
+  -- Note that there is a complexity here which was discovered in #13945: some
+  -- filesystems (e.g. NFS) will only allow exclusive locking if the fd was
+  -- opened for write access. We would previously try opening the lockfile for
+  -- read-only access first, however this failed when run on such filesystems.
+  -- Consequently, we now try read-write access first, falling back to read-only
+  -- if we are denied permission (e.g. in the case of a global database).
   catchJust
-    (\e -> if isDoesNotExistError e then Just () else Nothing)
-    (lockFileOpenIn ReadMode)
-    (const $ lockFileOpenIn ReadWriteMode)
+    (\e -> if isPermissionError e then Just () else Nothing)
+    (lockFileOpenIn ReadWriteMode)
+    (const $ lockFileOpenIn ReadMode)
   where
     lock = file <.> "lock"
 
@@ -261,16 +259,11 @@ lockPackageDbWith mode file = do
                    return $ PackageDbLock hnd
 
 lockPackageDb = lockPackageDbWith ExclusiveLock
-unlockPackageDb (PackageDbLock hnd) = hClose hnd
-
--- MIN_VERSION_base(4,10,0)
-#else
-
-lockPackageDb _file = return $ PackageDbLock ()
-unlockPackageDb _lock = return ()
-
--- MIN_VERSION_base(4,10,0)
+unlockPackageDb (PackageDbLock hnd) = do
+#if MIN_VERSION_base(4,11,0)
+    hUnlock hnd
 #endif
+    hClose hnd
 
 -- | Mode to open a package db in.
 data DbMode = DbReadOnly | DbReadWrite
@@ -400,7 +393,7 @@ decodeFromFile file mode decoder = case mode of
   -- shared lock on non-Windows platform because we update the database with an
   -- atomic rename, so readers will always see the database in a consistent
   -- state.
-#if MIN_VERSION_base(4,10,0) && defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS)
     bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do
 #endif
       (, DbOpenReadOnly) <$> decodeFileContents
diff --git a/libraries/ghc-boot/GHC/Serialized.hs b/libraries/ghc-boot/GHC/Serialized.hs
index 161bbb31f7..deb1a48edd 100644
--- a/libraries/ghc-boot/GHC/Serialized.hs
+++ b/libraries/ghc-boot/GHC/Serialized.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -19,6 +18,7 @@ module GHC.Serialized (
     serializeWithData, deserializeWithData,
   ) where
 
+import Prelude -- See note [Why do we import Prelude here?]
 import Data.Bits
 import Data.Word        ( Word8 )
 import Data.Data
@@ -34,16 +34,10 @@ toSerialized serialize what = Serialized (typeOf what) (serialize what)
 -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
 -- Otherwise return @Nothing@.
 fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
-#if MIN_VERSION_base(4,10,0)
 fromSerialized deserialize (Serialized the_type bytes)
   | the_type == rep = Just (deserialize bytes)
   | otherwise       = Nothing
   where rep = typeRep (Proxy :: Proxy a)
-#else
-fromSerialized deserialize (Serialized the_type bytes)
-  | the_type == typeOf (undefined :: a) = Just (deserialize bytes)
-  | otherwise                           = Nothing
-#endif
 
 -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
 serializeWithData :: Data a => a -> [Word8]
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index 11febb4ac0..58311b6ab9 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -34,14 +34,16 @@ source-repository head
 Library
     default-language: Haskell2010
     other-extensions: DeriveGeneric, RankNTypes, ScopedTypeVariables
+    default-extensions: NoImplicitPrelude
 
     exposed-modules:
             GHC.LanguageExtensions
             GHC.PackageDb
             GHC.Serialized
             GHC.ForeignSrcLang
+            GHC.HandleEncoding
 
-    build-depends: base       >= 4.7 && < 4.11,
+    build-depends: base       >= 4.7 && < 4.13,
                    binary     == 0.8.*,
                    bytestring == 0.10.*,
                    directory  >= 1.2 && < 1.4,