{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module System.IO.CodePage (
withCP65001
, withCP1200
, withCP1201
, withCP12000
, withCP12001
, withCP1252
, withCodePage
, withCodePageOptions
, CodePage
, cp65001
, cp1200
, cp1201
, cp12000
, cp12001
, cp1252
, Options
, defaultOptions
, chatty
, nonWindowsBehavior
, NonWindowsBehavior
, nonWindowsDoNothing
, nonWindowsFallbackCodePageEncoding
, defaultFallbackCodePageEncoding
) where
import Control.Exception (bracket_)
import Control.Monad (when)
import Data.Foldable (forM_)
import GHC.IO.Encoding (textEncodingName)
import System.IO ( TextEncoding, hGetEncoding, hPutStrLn, hSetEncoding
, stderr, stdin, stdout )
import System.IO.CodePage.Internal
#if MIN_VERSION_base(4,5,0)
import GHC.IO.Encoding (getLocaleEncoding, setLocaleEncoding)
#endif
#ifdef WINDOWS
import System.Win32.CodePage hiding (CodePage)
#endif
withCP65001 :: IO a -> IO a
withCP65001 = withCodePage cp65001
withCP1200 :: IO a -> IO a
withCP1200 = withCodePage cp1200
withCP1201 :: IO a -> IO a
withCP1201 = withCodePage cp1201
withCP12000 :: IO a -> IO a
withCP12000 = withCodePage cp12000
withCP12001 :: IO a -> IO a
withCP12001 = withCodePage cp12001
withCP1252 :: IO a -> IO a
withCP1252 = withCodePage cp1252
withCodePage :: CodePage -> IO a -> IO a
withCodePage = withCodePageOptions defaultOptions
withCodePageOptions :: Options -> CodePage -> IO a -> IO a
withCodePageOptions (Options{chatty, nonWindowsBehavior}) cp inner =
case nonWindowsBehavior of
NonWindowsDoNothing -> inner
NonWindowsFallbackCodePageEncoding fallback -> do
#ifdef WINDOWS
origCPI <- getConsoleCP
origCPO <- getConsoleOutputCP
#else
let origCPI = 0
origCPO = 0
#endif
mbOrigStdinEnc <- hGetEncoding stdin
mbOrigStdoutEnc <- hGetEncoding stdout
mbOrigStderrEnc <- hGetEncoding stderr
#if MIN_VERSION_base(4,5,0)
origLocaleEnc <- getLocaleEncoding
#endif
let expected = codePageEncoding' fallback cp
expectedName = textEncodingName expected
warn typ = when chatty $ hPutStrLn stderr $ concat
[ "Setting"
, typ
, " codepage to " ++ show cp
, if expectedName == ("CP" ++ show cp)
then ""
else " (" ++ expectedName ++ ")"
]
#ifdef WINDOWS
setInput = origCPI /= cp
setOutput = origCPO /= cp
#else
setInput = fmap textEncodingName mbOrigStdinEnc /= Just expectedName
setOutput = fmap textEncodingName mbOrigStdoutEnc /= Just expectedName
#endif
#if MIN_VERSION_base(4,5,0)
setLocale = textEncodingName origLocaleEnc /= expectedName
#endif
fixInput
| setInput = bracket_
(do
setConsoleCP' cp
hSetEncoding stdin expected
)
(do
setConsoleCP' origCPI
forM_ mbOrigStdinEnc $ hSetEncoding stdin
)
| otherwise = id
fixOutput
| setOutput = bracket_
(do
setConsoleOutputCP' cp
hSetEncoding stdout expected
hSetEncoding stderr expected
)
(do
setConsoleOutputCP' origCPO
forM_ mbOrigStdoutEnc $ hSetEncoding stdout
forM_ mbOrigStderrEnc $ hSetEncoding stderr
)
| otherwise = id
fixLocale
#if MIN_VERSION_base(4,5,0)
| setLocale
= bracket_
(do when chatty $ hPutStrLn stderr $ unwords
[ "Setting locale encoding to"
, expectedName
]
setLocaleEncoding expected)
(setLocaleEncoding origLocaleEnc)
| otherwise
#endif
= id
case (setInput, setOutput) of
(False, False) -> return ()
(True, True) -> warn ""
(True, False) -> warn " input"
(False, True) -> warn " output"
fixInput $ fixOutput $ fixLocale inner
codePageEncoding' :: (CodePage -> TextEncoding) -> CodePage -> TextEncoding
#ifdef WINDOWS
codePageEncoding' _ = codePageEncoding
#else
codePageEncoding' = id
#endif
setConsoleCP', setConsoleOutputCP' :: CodePage -> IO ()
#ifdef WINDOWS
setConsoleCP' = setConsoleCP
setConsoleOutputCP' = setConsoleOutputCP
#else
setConsoleCP' _ = return ()
setConsoleOutputCP' _ = return ()
#endif