{-# 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 :: IO ()
setConsoleEncoding =
#ifdef mingw32_HOST_OS
    do codepage <- getACP
       setCP codepage
       setEncoding ("CP"++show codepage)
#endif
       () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () :: IO ()

changeConsoleEncoding :: String -> IO ()
changeConsoleEncoding String
code =
    do
#ifdef mingw32_HOST_OS
       maybe (return ()) setCP (readCP code)
#endif
       String -> IO ()
setEncoding String
code

setEncoding :: String -> IO ()
setEncoding String
code =
    do TextEncoding
enc <- String -> IO TextEncoding
mkTextEncoding String
code
       Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdin  TextEncoding
enc
       Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdout TextEncoding
enc
       Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stderr TextEncoding
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 { TermColors -> String
redFg,TermColors -> String
blueFg,TermColors -> String
restore :: String } deriving Int -> TermColors -> ShowS
[TermColors] -> ShowS
TermColors -> String
(Int -> TermColors -> ShowS)
-> (TermColors -> String)
-> ([TermColors] -> ShowS)
-> Show TermColors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TermColors] -> ShowS
$cshowList :: [TermColors] -> ShowS
show :: TermColors -> String
$cshow :: TermColors -> String
showsPrec :: Int -> TermColors -> ShowS
$cshowsPrec :: Int -> TermColors -> ShowS
Show
noTermColors :: TermColors
noTermColors = String -> String -> String -> TermColors
TermColors String
"" String
"" String
""

getTermColors :: MonadIO m => m TermColors
#ifdef mingw32_HOST_OS
getTermColors = return noTermColors
#else
getTermColors :: m TermColors
getTermColors =
    IO TermColors -> m TermColors
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TermColors -> m TermColors) -> IO TermColors -> m TermColors
forall a b. (a -> b) -> a -> b
$
    do Terminal
term <- IO Terminal
setupTermFromEnv
       TermColors -> IO TermColors
forall (m :: * -> *) a. Monad m => a -> m a
return (TermColors -> IO TermColors) -> TermColors -> IO TermColors
forall a b. (a -> b) -> a -> b
$ TermColors
-> (TermColors -> TermColors) -> Maybe TermColors -> TermColors
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TermColors
noTermColors TermColors -> TermColors
forall a. a -> a
id (Maybe TermColors -> TermColors) -> Maybe TermColors -> TermColors
forall a b. (a -> b) -> a -> b
$ Terminal -> Capability TermColors -> Maybe TermColors
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term (Capability TermColors -> Maybe TermColors)
-> Capability TermColors -> Maybe TermColors
forall a b. (a -> b) -> a -> b
$
         do Int
n <- Capability Int
termColors
            Bool -> Capability ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
8)
            Color -> String
fg <- Capability (Color -> String)
forall s. TermStr s => Capability (Color -> s)
setForegroundColor
            String
restore <- Capability String
forall s. TermStr s => Capability s
restoreDefaultColors
            TermColors -> Capability TermColors
forall (m :: * -> *) a. Monad m => a -> m a
return (TermColors -> Capability TermColors)
-> TermColors -> Capability TermColors
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> TermColors
TermColors (Color -> String
fg Color
Red) (Color -> String
fg Color
Blue) String
restore
#endif