forked from GitHub/gf-core
72 lines
1.8 KiB
Haskell
72 lines
1.8 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module GF.System.Console(
|
|
-- ** Console IO
|
|
-- *** Changing which character encoding to use for console IO
|
|
setConsoleEncoding,changeConsoleEncoding,
|
|
-- *** Console colors
|
|
TermColors(..),getTermColors
|
|
) where
|
|
import System.IO
|
|
import Control.Monad(guard)
|
|
import Control.Monad.Trans(MonadIO(..))
|
|
#ifdef mingw32_HOST_OS
|
|
import System.Win32.Console
|
|
import System.Win32.NLS
|
|
#else
|
|
import System.Console.Terminfo
|
|
#endif
|
|
|
|
-- | Set the console encoding (for Windows, has no effect on Unix-like systems)
|
|
setConsoleEncoding =
|
|
#ifdef mingw32_HOST_OS
|
|
do codepage <- getACP
|
|
setCP codepage
|
|
setEncoding ("CP"++show codepage)
|
|
#endif
|
|
return () :: IO ()
|
|
|
|
changeConsoleEncoding code =
|
|
do
|
|
#ifdef mingw32_HOST_OS
|
|
maybe (return ()) setCP (readCP code)
|
|
#endif
|
|
setEncoding code
|
|
|
|
setEncoding code =
|
|
do enc <- mkTextEncoding code
|
|
hSetEncoding stdin enc
|
|
hSetEncoding stdout enc
|
|
hSetEncoding stderr enc
|
|
|
|
#ifdef mingw32_HOST_OS
|
|
setCP codepage =
|
|
do setConsoleCP codepage
|
|
setConsoleOutputCP codepage
|
|
|
|
readCP code =
|
|
case code of
|
|
'C':'P':c -> case reads c of
|
|
[(cp,"")] -> Just cp
|
|
_ -> Nothing
|
|
"UTF-8" -> Just 65001
|
|
_ -> Nothing
|
|
#endif
|
|
|
|
data TermColors = TermColors { redFg,blueFg,restore :: String } deriving Show
|
|
noTermColors = TermColors "" "" ""
|
|
|
|
getTermColors :: MonadIO m => m TermColors
|
|
#ifdef mingw32_HOST_OS
|
|
getTermColors = return noTermColors
|
|
#else
|
|
getTermColors =
|
|
liftIO $
|
|
do term <- setupTermFromEnv
|
|
return $ maybe noTermColors id $ getCapability term $
|
|
do n <- termColors
|
|
guard (n>=8)
|
|
fg <- setForegroundColor
|
|
restore <- restoreDefaultColors
|
|
return $ TermColors (fg Red) (fg Blue) restore
|
|
#endif
|