{-# LANGUAGE NoImplicitPrelude        #-}
{-# LANGUAGE OverloadedStrings        #-}

-- | The module of this name differs as between Windows and non-Windows builds.

-- This is the Windows version.

module System.Terminal
  ( fixCodePage
  , getTerminalWidth
  , hIsTerminalDeviceOrMinTTY
  ) where

import           Distribution.Types.Version ( mkVersion )
import           Foreign.Marshal.Alloc ( allocaBytes )
import           Foreign.Ptr ( Ptr )
import           Foreign.Storable ( peekByteOff )
import           RIO.Partial ( read )
import           Stack.Prelude
import           System.IO ( hGetContents )
import           System.Process
                   ( StdStream (..), createProcess, shell, std_err, std_in
                   , std_out, waitForProcess
                   )
import           System.Win32 ( isMinTTYHandle, withHandleToHANDLE )
import           System.Win32.Console
                   ( setConsoleCP, setConsoleOutputCP, getConsoleCP
                   , getConsoleOutputCP
                   )

type HANDLE = Ptr ()

data CONSOLE_SCREEN_BUFFER_INFO

sizeCONSOLE_SCREEN_BUFFER_INFO :: Int
sizeCONSOLE_SCREEN_BUFFER_INFO :: Int
sizeCONSOLE_SCREEN_BUFFER_INFO = Int
22

posCONSOLE_SCREEN_BUFFER_INFO_srWindow :: Int
posCONSOLE_SCREEN_BUFFER_INFO_srWindow :: Int
posCONSOLE_SCREEN_BUFFER_INFO_srWindow = Int
10 -- 4 x Word16 Left,Top,Right,Bottom


c_STD_OUTPUT_HANDLE :: Int
c_STD_OUTPUT_HANDLE :: Int
c_STD_OUTPUT_HANDLE = -Int
11

foreign import ccall unsafe "windows.h GetConsoleScreenBufferInfo"
  c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool

foreign import ccall unsafe "windows.h GetStdHandle"
  c_GetStdHandle :: Int -> IO HANDLE


getTerminalWidth :: IO (Maybe Int)
getTerminalWidth :: IO (Maybe Int)
getTerminalWidth = do
  HANDLE
hdl <- Int -> IO HANDLE
c_GetStdHandle Int
c_STD_OUTPUT_HANDLE
  Int
-> (Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO (Maybe Int))
-> IO (Maybe Int)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeCONSOLE_SCREEN_BUFFER_INFO ((Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO (Maybe Int))
 -> IO (Maybe Int))
-> (Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO (Maybe Int))
-> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ \Ptr CONSOLE_SCREEN_BUFFER_INFO
p -> do
    Bool
b <- HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool
c_GetConsoleScreenBufferInfo HANDLE
hdl Ptr CONSOLE_SCREEN_BUFFER_INFO
p
    if Bool -> Bool
not Bool
b
      then do -- This could happen on Cygwin or MSYS

        let stty :: CreateProcess
stty = (String -> CreateProcess
shell String
"stty size") {
              std_in :: StdStream
std_in  = Handle -> StdStream
UseHandle Handle
stdin
            , std_out :: StdStream
std_out = StdStream
CreatePipe
            , std_err :: StdStream
std_err = StdStream
CreatePipe
            }
        (Maybe Handle
_, Maybe Handle
mbStdout, Maybe Handle
_, ProcessHandle
rStty) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
stty
        ExitCode
exStty <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
rStty
        case ExitCode
exStty of
          ExitFailure Int
_ -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
          ExitCode
ExitSuccess ->
            IO (Maybe Int)
-> (Handle -> IO (Maybe Int)) -> Maybe Handle -> IO (Maybe Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing)
                  (\Handle
hSize -> do
                      String
sizeStr <- Handle -> IO String
hGetContents Handle
hSize
                      case (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. Read a => String -> a
read ([String] -> [Int]) -> [String] -> [Int]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
sizeStr :: [Int] of
                        [Int
_r, Int
c] -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> IO (Maybe Int)) -> Maybe Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
c
                        [Int]
_ -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
                  )
                  Maybe Handle
mbStdout
      else do
        [Int
left,Int
_top,Int
right,Int
_bottom] <- [Int] -> (Int -> IO Int) -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
3] ((Int -> IO Int) -> IO [Int]) -> (Int -> IO Int) -> IO [Int]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
          Word16
v <- Ptr CONSOLE_SCREEN_BUFFER_INFO -> Int -> IO Word16
forall b. Ptr b -> Int -> IO Word16
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CONSOLE_SCREEN_BUFFER_INFO
p (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
posCONSOLE_SCREEN_BUFFER_INFO_srWindow)
          Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
v :: Word16)
        Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> IO (Maybe Int)) -> Maybe Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
right Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
left)

-- | Set the code page for this process as necessary. Only applies to Windows.

-- See: https://github.com/commercialhaskell/stack/issues/738

fixCodePage ::
     HasTerm env
  => Bool -- ^ modify code page?

  -> Version -- ^ GHC version

  -> RIO env a
  -> RIO env a
fixCodePage :: forall env a.
HasTerm env =>
Bool -> Version -> RIO env a -> RIO env a
fixCodePage Bool
mcp Version
ghcVersion RIO env a
inner =
  if Bool
mcp Bool -> Bool -> Bool
&& Version
ghcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
10, Int
3]
    then RIO env a
fixCodePage'
    -- GHC >=7.10.3 doesn't need this code page hack.

    else RIO env a
inner
 where
  fixCodePage' :: RIO env a
fixCodePage' = do
    UINT
origCPI <- IO UINT -> RIO env UINT
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UINT
getConsoleCP
    UINT
origCPO <- IO UINT -> RIO env UINT
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UINT
getConsoleOutputCP

    let setInput :: Bool
setInput = UINT
origCPI UINT -> UINT -> Bool
forall a. Eq a => a -> a -> Bool
/= UINT
expected
        setOutput :: Bool
setOutput = UINT
origCPO UINT -> UINT -> Bool
forall a. Eq a => a -> a -> Bool
/= UINT
expected
        fixInput :: RIO env c -> RIO env c
fixInput
          | Bool
setInput = RIO env () -> RIO env () -> RIO env c -> RIO env c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_
              (IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ UINT -> IO ()
setConsoleCP UINT
expected)
              (IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ UINT -> IO ()
setConsoleCP UINT
origCPI)
          | Bool
otherwise = RIO env c -> RIO env c
forall a. a -> a
id
        fixOutput :: RIO env c -> RIO env c
fixOutput
          | Bool
setOutput = RIO env () -> RIO env () -> RIO env c -> RIO env c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_
              (IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ UINT -> IO ()
setConsoleOutputCP UINT
expected)
              (IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ UINT -> IO ()
setConsoleOutputCP UINT
origCPO)
          | Bool
otherwise = RIO env c -> RIO env c
forall a. a -> a
id

    case (Bool
setInput, Bool
setOutput) of
      (Bool
False, Bool
False) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (Bool
True, Bool
True) -> [StyleDoc] -> RIO env ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
warn []
      (Bool
True, Bool
False) -> [StyleDoc] -> RIO env ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
warn [StyleDoc
"input"]
      (Bool
False, Bool
True) -> [StyleDoc] -> RIO env ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
warn [StyleDoc
"output"]

    RIO env a -> RIO env a
forall {c}. RIO env c -> RIO env c
fixInput (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ RIO env a -> RIO env a
forall {c}. RIO env c -> RIO env c
fixOutput RIO env a
inner
  expected :: UINT
expected = UINT
65001 -- UTF-8

  warn :: [StyleDoc] -> m ()
warn [StyleDoc]
typ = [StyleDoc] -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL ([StyleDoc] -> m ()) -> [StyleDoc] -> m ()
forall a b. (a -> b) -> a -> b
$
       StyleDoc
"Setting"
    StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
:  [StyleDoc]
typ
    [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ String -> StyleDoc
flow String
"codepage to UTF-8 (65001) to ensure correct output from GHC." ]

-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal

-- devices, but isMinTTYHandle does.

hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY :: forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
h = do
  Bool
isTD <- Handle -> m Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDevice Handle
h
  if Bool
isTD
    then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    else IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Handle -> (HANDLE -> IO Bool) -> IO Bool
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE Handle
h HANDLE -> IO Bool
isMinTTYHandle