[PATCH] Form UTF-8 for file reading/writing

From ba427d513095fc75933408502fa3426e45f795b8 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Sat, 1 Jun 2024 20:24:18 +0800
Subject: [PATCH] Form UTF-8 for file reading/writing

---
 driver/Main.hs                                | 34 +++++++++++++++++--
 haddock-api/src/Haddock.hs                    |  3 +-
 haddock-api/src/Haddock/Backends/Xhtml.hs     |  2 +-
 .../src/Haddock/Backends/Xhtml/Meta.hs        |  5 +--
 haddock-api/src/Haddock/Utils.hs              | 28 ++++++++++++++-
 haddock-library/fixtures/Fixtures.hs          |  4 +--
 6 files changed, 66 insertions(+), 10 deletions(-)

diff --git a/driver/Main.hs b/driver/Main.hs
index 44df4692..bc62e823 100644
--- a/driver/Main.hs
+++ b/driver/Main.hs
@@ -1,7 +1,37 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Main where
 
 import Documentation.Haddock (haddock)
-import GHC.ResponseFile (getArgsWithResponseFiles)
+import System.Environment (getArgs)
+import GHC.ResponseFile (unescapeArgs)
+import Control.Exception
+import System.IO (hPutStrLn, stderr, IOMode (ReadMode), hSetEncoding, utf8, openFile)
+import System.Exit (exitFailure)
+import GHC.IO.Handle (hGetContents)
 
 main :: IO ()
-main = getArgsWithResponseFiles >>= haddock
+main = getArgsWithResponseFiles' >>= haddock
+
+
+getArgsWithResponseFiles' :: IO [String]
+getArgsWithResponseFiles' = getArgs >>= expandResponse
+ where
+  readUtf8File :: FilePath -> IO String
+  readUtf8File filepath = do
+      h <- openFile filepath ReadMode
+      hSetEncoding h utf8
+      hGetContents h
+
+  expandResponse :: [String] -> IO [String]
+  expandResponse = fmap concat . mapM expand
+    where
+      expand :: String -> IO [String]
+      expand ('@':f) = readFileExc f >>= return . unescapeArgs
+      expand x = return [x]
+
+      readFileExc f =
+        readUtf8File f `catch` \(e :: IOException) -> do
+          hPutStrLn stderr $ "Error while expanding response file: " ++ show e
+          exitFailure
+
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 958f3512..3ca5b86e 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -772,8 +772,7 @@ getPrologue dflags flags =
   case [filename | Flag_Prologue filename <- flags ] of
     [] -> return Nothing
     [filename] -> do
-      h <- openFile filename ReadMode
-      hSetEncoding h utf8
+      h <- openUtf8File filename ReadMode
       str <- hGetContents h -- semi-closes the handle
       return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str
     _ -> throwE "multiple -p/--prologue options"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 3dc1e8da..551e026b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -471,7 +471,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
             installedIfacesPaths
   traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)
             errors
-  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->
+  withUtf8BinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->
       Builder.hPutBuilder
         h (encodeToBuilder (encodeIndexes (concat installedIndexes)))
   where
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
index 227775f9..861392a5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
@@ -1,11 +1,12 @@
 module Haddock.Backends.Xhtml.Meta where
 
+import Haddock.Utils
 import Haddock.Utils.Json
 import Haddock.Version
 
 import Data.ByteString.Builder (hPutBuilder)
 import System.FilePath ((</>))
-import System.IO (withFile, IOMode (WriteMode))
+import System.IO (IOMode (WriteMode))
 
 -- | Everytime breaking changes to the Quckjump api
 -- happen this needs to be modified.
@@ -24,5 +25,5 @@ writeHaddockMeta odir withQuickjump = do
       [ "quickjump_version" .= quickjumpVersion | withQuickjump ]
       )
 
-  withFile (odir </> "meta.json") WriteMode $ \h ->
+  withUtf8File (odir </> "meta.json") WriteMode $ \h ->
     hPutBuilder h (encodeToBuilder meta_json)
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 314b8db9..64d2dffa 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -31,6 +31,10 @@ module Haddock.Utils (
   -- * Miscellaneous utilities
   getProgramName, bye, die, escapeStr,
   writeUtf8File, withTempDir,
+  readUtf8File,
+  openUtf8File,
+  withUtf8File,
+  withUtf8BinaryFile,
 
   -- * HTML cross reference mapping
   html_xrefs_ref, html_xrefs_ref',
@@ -68,7 +72,7 @@ import Data.List ( isSuffixOf )
 import System.Environment ( getProgName )
 import System.Exit
 import System.Directory ( createDirectory, removeDirectoryRecursive )
-import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile )
+import System.IO ( hPutStr, hGetContents, hSetEncoding, IOMode(..), utf8, withFile, withBinaryFile, Handle, openFile )
 import System.IO.Unsafe ( unsafePerformIO )
 import qualified System.FilePath.Posix as HtmlPath
 
@@ -279,6 +283,28 @@ writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do
     hSetEncoding h utf8
     hPutStr h contents
 
+readUtf8File :: FilePath -> IO String
+readUtf8File filepath = do
+  h <- openFile filepath ReadMode
+  hSetEncoding h utf8
+  hGetContents h
+
+openUtf8File :: FilePath -> IOMode -> IO Handle
+openUtf8File filepath iomode = do
+  h <- openFile filepath iomode
+  hSetEncoding h utf8
+  pure h
+
+withUtf8File :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withUtf8File fp iomode action = withFile fp iomode $ \h -> do
+  hSetEncoding h utf8
+  action h
+
+withUtf8BinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
+withUtf8BinaryFile fp iomode action = withBinaryFile fp iomode $ \h -> do
+  hSetEncoding h utf8
+  action h
+
 withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a
 withTempDir dir = bracket_ (liftIO $ createDirectory dir)
                            (liftIO $ removeDirectoryRecursive dir)
diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs
index 374a664c..c10adc38 100644
--- a/haddock-library/fixtures/Fixtures.hs
+++ b/haddock-library/fixtures/Fixtures.hs
@@ -80,7 +80,7 @@ runFixtures fixtures = do
     results <- for fixtures $ \(Fixture i o) -> do
         let name = takeBaseName i
         let readDoc = do
-                input <- readFile i
+                input <- readUtf8File i
                 return (parseString input)
         ediffGolden goldenFixture name o readDoc
     case foldl' combineResults (Result 0 0) results of
@@ -95,7 +95,7 @@ listFixtures = traverse_ $ \(Fixture i _) -> do
 
 acceptFixtures :: [Fixture] -> IO ()
 acceptFixtures = traverse_ $ \(Fixture i o) -> do
-    input <- readFile i
+    input <- readUtf8File i
     let doc = parseString input
     let actual = show (prettyExpr $ toExpr doc) ++ "\n"
     writeFile o actual
-- 
2.45.1