-- | When we try to read a file that is encoded in UTF-8, and the system locale
-- is not set to UTF-8, the GHC runtime system will throw an error:
--
-- <https://github.com/jaspervdj/patat/issues/127>
--
-- However, we don't want to force people to use UTF-8 for everything.  So what
-- we do is provide a replacement readFile, which first tries to read the file
-- in the system locale, and then falls back to forcing UTF-8.
--
-- If we forced UTF-8, we also want to propagate that to the output handle;
-- otherwise will get errors when we try to display these characters; so
-- withHandle should be used on the output handle (typically stdout).
module Patat.EncodingFallback
    ( EncodingFallback (..)
    , readFile
    , withHandle
    ) where


--------------------------------------------------------------------------------
import           Control.Exception (bracket, throwIO)
import           Control.Monad     (when)
import qualified Data.Text         as T
import qualified Data.Text.IO      as T
import           Prelude           hiding (readFile)
import qualified System.IO         as IO
import qualified System.IO.Error   as IO


--------------------------------------------------------------------------------
data EncodingFallback = NoFallback | Utf8Fallback
    deriving (EncodingFallback -> EncodingFallback -> Bool
(EncodingFallback -> EncodingFallback -> Bool)
-> (EncodingFallback -> EncodingFallback -> Bool)
-> Eq EncodingFallback
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EncodingFallback -> EncodingFallback -> Bool
== :: EncodingFallback -> EncodingFallback -> Bool
$c/= :: EncodingFallback -> EncodingFallback -> Bool
/= :: EncodingFallback -> EncodingFallback -> Bool
Eq, Int -> EncodingFallback -> ShowS
[EncodingFallback] -> ShowS
EncodingFallback -> String
(Int -> EncodingFallback -> ShowS)
-> (EncodingFallback -> String)
-> ([EncodingFallback] -> ShowS)
-> Show EncodingFallback
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncodingFallback -> ShowS
showsPrec :: Int -> EncodingFallback -> ShowS
$cshow :: EncodingFallback -> String
show :: EncodingFallback -> String
$cshowList :: [EncodingFallback] -> ShowS
showList :: [EncodingFallback] -> ShowS
Show)


--------------------------------------------------------------------------------
readFile :: FilePath -> IO (EncodingFallback, T.Text)
readFile :: String -> IO (EncodingFallback, Text)
readFile String
path = IO (EncodingFallback, Text)
-> (IOError -> IO (EncodingFallback, Text))
-> IO (EncodingFallback, Text)
forall a. IO a -> (IOError -> IO a) -> IO a
IO.catchIOError IO (EncodingFallback, Text)
readSystem ((IOError -> IO (EncodingFallback, Text))
 -> IO (EncodingFallback, Text))
-> (IOError -> IO (EncodingFallback, Text))
-> IO (EncodingFallback, Text)
forall a b. (a -> b) -> a -> b
$ \IOError
ioe -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IOError -> Bool
IO.isDoesNotExistError IOError
ioe) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
ioe  -- Don't retry on these
    IO (EncodingFallback, Text)
readUtf8
  where
    readSystem :: IO (EncodingFallback, Text)
readSystem = ((,) EncodingFallback
NoFallback (Text -> (EncodingFallback, Text))
-> IO Text -> IO (EncodingFallback, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
path)
    readUtf8 :: IO (EncodingFallback, Text)
readUtf8   = String
-> IOMode
-> (Handle -> IO (EncodingFallback, Text))
-> IO (EncodingFallback, Text)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
path IOMode
IO.ReadMode ((Handle -> IO (EncodingFallback, Text))
 -> IO (EncodingFallback, Text))
-> (Handle -> IO (EncodingFallback, Text))
-> IO (EncodingFallback, Text)
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
h TextEncoding
IO.utf8_bom
        (,) EncodingFallback
Utf8Fallback (Text -> (EncodingFallback, Text))
-> IO Text -> IO (EncodingFallback, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Text
T.hGetContents Handle
h


--------------------------------------------------------------------------------
withHandle :: IO.Handle -> EncodingFallback -> IO a -> IO a
withHandle :: forall a. Handle -> EncodingFallback -> IO a -> IO a
withHandle Handle
_ EncodingFallback
NoFallback   IO a
mx = IO a
mx
withHandle Handle
h EncodingFallback
Utf8Fallback IO a
mx = IO (Maybe TextEncoding)
-> (Maybe TextEncoding -> IO (Maybe ()))
-> (Maybe TextEncoding -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (do
        Maybe TextEncoding
mbOld <- Handle -> IO (Maybe TextEncoding)
IO.hGetEncoding Handle
h
        Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
h TextEncoding
IO.utf8
        Maybe TextEncoding -> IO (Maybe TextEncoding)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TextEncoding
mbOld)
    (\Maybe TextEncoding
mbOld -> (TextEncoding -> IO ()) -> Maybe TextEncoding -> IO (Maybe ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
h) Maybe TextEncoding
mbOld)
    (\Maybe TextEncoding
_ -> IO a
mx)