{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}

{-|
Module:      System.IO.CodePage
Copyright:   (C) 2016-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: Portable

Exports functions which adjust code pages on Windows, and do nothing on other
operating systems.
-}
module System.IO.CodePage (
      -- * Adjusting 'CodePage's
      withCP65001
    , withCP1200
    , withCP1201
    , withCP12000
    , withCP12001
    , withCP1252
    , withCodePage
    , withCodePageOptions

      -- * Notable 'CodePage's
    , CodePage
    , cp65001
    , cp1200
    , cp1201
    , cp12000
    , cp12001
    , cp1252

      -- * 'Options'
    , Options
    , defaultOptions
      -- ** Record fields of 'Options'
    , chatty
    , nonWindowsBehavior

      -- ** 'NonWindowsBehavior'
    , NonWindowsBehavior
      -- ** Constructing '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

-- | Sets the code page for an action to UTF-8 as necessary.
withCP65001 :: IO a -> IO a
withCP65001 :: IO a -> IO a
withCP65001 = CodePage -> IO a -> IO a
forall a. CodePage -> IO a -> IO a
withCodePage CodePage
cp65001

-- | Sets the code page for an action to UTF-16LE as necessary.
withCP1200 :: IO a -> IO a
withCP1200 :: IO a -> IO a
withCP1200 = CodePage -> IO a -> IO a
forall a. CodePage -> IO a -> IO a
withCodePage CodePage
cp1200

-- | Sets the code page for an action to UTF-16BE as necessary.
withCP1201 :: IO a -> IO a
withCP1201 :: IO a -> IO a
withCP1201 = CodePage -> IO a -> IO a
forall a. CodePage -> IO a -> IO a
withCodePage CodePage
cp1201

-- | Sets the code page for an action to UTF-32LE as necessary.
withCP12000 :: IO a -> IO a
withCP12000 :: IO a -> IO a
withCP12000 = CodePage -> IO a -> IO a
forall a. CodePage -> IO a -> IO a
withCodePage CodePage
cp12000

-- | Sets the code page for an action to UTF-32BE as necessary.
withCP12001 :: IO a -> IO a
withCP12001 :: IO a -> IO a
withCP12001 = CodePage -> IO a -> IO a
forall a. CodePage -> IO a -> IO a
withCodePage CodePage
cp12001

-- | Sets the code page for an action to Latin1 as necessary.
withCP1252 :: IO a -> IO a
withCP1252 :: IO a -> IO a
withCP1252 = CodePage -> IO a -> IO a
forall a. CodePage -> IO a -> IO a
withCodePage CodePage
cp1252

-- | Sets the code page for an action as necessary.
--
-- On operating systems besides Windows, this will make an effort to change
-- the current 'TextEncoding' to something that is equivalent to the supplied
-- 'CodePage'. Currently, the only supported 'CodePage's on non-Windows OSes
-- are 'cp65001', 'cp1200', 'cp1201', 'cp12000', and 'cp12001'. Supplying any
-- other 'CodePage' will result in a runtime error on non-Windows OSes. (If you
-- would like to configure this behavior, use 'withCodePageOptions' instead.)
withCodePage :: CodePage -> IO a -> IO a
withCodePage :: CodePage -> IO a -> IO a
withCodePage = Options -> CodePage -> IO a -> IO a
forall a. Options -> CodePage -> IO a -> IO a
withCodePageOptions Options
defaultOptions

-- | Sets the code page for an action as necessary. If the 'Bool' argument is 'True',
-- this function will emit a warning to @stderr@ indicating that the code page has
-- been changed. ('withCodePage' sets this argument to 'False'.)

-- Taken from the stack codebase
-- (https://github.com/commercialhaskell/stack/blob/21e517ba88b3c6bee475fb00ad95f280e7285a54/src/main/Main.hs#L82-L123)
-- which is under a 3-clause BSD license
withCodePageOptions :: Options -> CodePage -> IO a -> IO a
withCodePageOptions :: Options -> CodePage -> IO a -> IO a
withCodePageOptions (Options{Bool
chatty :: Bool
chatty :: Options -> Bool
chatty, NonWindowsBehavior
nonWindowsBehavior :: NonWindowsBehavior
nonWindowsBehavior :: Options -> NonWindowsBehavior
nonWindowsBehavior}) CodePage
cp IO a
inner =
  case NonWindowsBehavior
nonWindowsBehavior of
    NonWindowsBehavior
NonWindowsDoNothing -> IO a
inner
    NonWindowsFallbackCodePageEncoding CodePage -> TextEncoding
fallback -> do
#ifdef WINDOWS
      origCPI <- getConsoleCP
      origCPO <- getConsoleOutputCP
#else
      -- These are never used on non-Windows OSes,
      -- so their values are irrelevant
      let origCPI :: CodePage
origCPI = CodePage
0
          origCPO :: CodePage
origCPO = CodePage
0
#endif
      Maybe TextEncoding
mbOrigStdinEnc  <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
stdin
      Maybe TextEncoding
mbOrigStdoutEnc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
stdout
      Maybe TextEncoding
mbOrigStderrEnc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
stderr
#if MIN_VERSION_base(4,5,0)
      TextEncoding
origLocaleEnc   <- IO TextEncoding
getLocaleEncoding
#endif

      let expected :: TextEncoding
expected     = (CodePage -> TextEncoding) -> CodePage -> TextEncoding
codePageEncoding' CodePage -> TextEncoding
fallback CodePage
cp
          expectedName :: String
expectedName = TextEncoding -> String
textEncodingName TextEncoding
expected
          warn :: String -> IO ()
warn String
typ = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
chatty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ String
"Setting"
              , String
typ
              , String
" codepage to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodePage -> String
forall a. Show a => a -> String
show CodePage
cp
              , if String
expectedName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"CP" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CodePage -> String
forall a. Show a => a -> String
show CodePage
cp)
                   then String
""
                   else String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expectedName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
              ]
#ifdef WINDOWS
          setInput  = origCPI /= cp
          setOutput = origCPO /= cp
#else
          -- Crude, but the best available option
          setInput :: Bool
setInput  = (TextEncoding -> String) -> Maybe TextEncoding -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> String
textEncodingName Maybe TextEncoding
mbOrigStdinEnc  Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Maybe String
forall a. a -> Maybe a
Just String
expectedName
          setOutput :: Bool
setOutput = (TextEncoding -> String) -> Maybe TextEncoding -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> String
textEncodingName Maybe TextEncoding
mbOrigStdoutEnc Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Maybe String
forall a. a -> Maybe a
Just String
expectedName
#endif
#if MIN_VERSION_base(4,5,0)
          setLocale :: Bool
setLocale = TextEncoding -> String
textEncodingName TextEncoding
origLocaleEnc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
expectedName
#endif
          fixInput :: IO c -> IO c
fixInput
              | Bool
setInput = IO () -> IO () -> IO c -> IO c
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
                  (do
                      CodePage -> IO ()
setConsoleCP' CodePage
cp
                      Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdin TextEncoding
expected
                      )
                  (do
                      CodePage -> IO ()
setConsoleCP' CodePage
origCPI
                      Maybe TextEncoding -> (TextEncoding -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe TextEncoding
mbOrigStdinEnc ((TextEncoding -> IO ()) -> IO ())
-> (TextEncoding -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdin
                      )
              | Bool
otherwise = IO c -> IO c
forall a. a -> a
id
          fixOutput :: IO c -> IO c
fixOutput
              | Bool
setOutput = IO () -> IO () -> IO c -> IO c
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
                  (do
                      CodePage -> IO ()
setConsoleOutputCP' CodePage
cp
                      Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdout TextEncoding
expected
                      Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stderr TextEncoding
expected
                      )
                  (do
                      CodePage -> IO ()
setConsoleOutputCP' CodePage
origCPO
                      Maybe TextEncoding -> (TextEncoding -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe TextEncoding
mbOrigStdoutEnc ((TextEncoding -> IO ()) -> IO ())
-> (TextEncoding -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdout
                      Maybe TextEncoding -> (TextEncoding -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe TextEncoding
mbOrigStderrEnc ((TextEncoding -> IO ()) -> IO ())
-> (TextEncoding -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stderr
                      )
              | Bool
otherwise = IO c -> IO c
forall a. a -> a
id
          fixLocale :: IO c -> IO c
fixLocale
#if MIN_VERSION_base(4,5,0)
              | Bool
setLocale
              = IO () -> IO () -> IO c -> IO c
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
                  (do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
chatty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
                        [ String
"Setting locale encoding to"
                        , String
expectedName
                        ]
                      TextEncoding -> IO ()
setLocaleEncoding TextEncoding
expected)
                  (TextEncoding -> IO ()
setLocaleEncoding TextEncoding
origLocaleEnc)
              | Bool
otherwise
#endif
              = IO c -> IO c
forall a. a -> a
id

      case (Bool
setInput, Bool
setOutput) of
          (Bool
False, Bool
False) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Bool
True, Bool
True) -> String -> IO ()
warn String
""
          (Bool
True, Bool
False) -> String -> IO ()
warn String
" input"
          (Bool
False, Bool
True) -> String -> IO ()
warn String
" output"

      IO a -> IO a
forall c. IO c -> IO c
fixInput (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall c. IO c -> IO c
fixOutput (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall c. IO c -> IO c
fixLocale IO a
inner

codePageEncoding' :: (CodePage -> TextEncoding) -> CodePage -> TextEncoding
#ifdef WINDOWS
codePageEncoding' _ = codePageEncoding
#else
codePageEncoding' :: (CodePage -> TextEncoding) -> CodePage -> TextEncoding
codePageEncoding' = (CodePage -> TextEncoding) -> CodePage -> TextEncoding
forall a. a -> a
id
#endif

setConsoleCP', setConsoleOutputCP' :: CodePage -> IO ()
#ifdef WINDOWS
setConsoleCP'       = setConsoleCP
setConsoleOutputCP' = setConsoleOutputCP
#else
setConsoleCP' :: CodePage -> IO ()
setConsoleCP'       CodePage
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setConsoleOutputCP' :: CodePage -> IO ()
setConsoleOutputCP' CodePage
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif