49 lines
1.7 KiB
Haskell
49 lines
1.7 KiB
Haskell
|
{-# LANGUAGE CPP #-}
|
||
|
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
{-# LANGUAGE FlexibleContexts #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
|
||
|
|
module GHCup.Utils.Windows where
|
||
|
|
|
||
|
|
|
||
|
|
import Control.Exception.Safe
|
||
|
|
import Control.Monad
|
||
|
|
#if !MIN_VERSION_base(4,13,0)
|
||
|
|
import Control.Monad.Fail ( MonadFail )
|
||
|
|
#endif
|
||
|
|
import Data.Bits
|
||
|
|
|
||
|
|
import System.Win32.Console
|
||
|
|
import System.Win32.File hiding ( copyFile )
|
||
|
|
import System.Win32.Types
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
-- | Enables ANSI support on windows, does nothing on unix.
|
||
|
|
--
|
||
|
|
-- Returns 'Left str' on errors and 'Right bool' on success, where
|
||
|
|
-- 'bool' markes whether ansi support was already enabled.
|
||
|
|
--
|
||
|
|
-- This function never crashes.
|
||
|
|
--
|
||
|
|
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
|
||
|
|
enableAnsiSupport :: IO (Either String Bool)
|
||
|
|
enableAnsiSupport = handleIO (pure . Left . displayException) $ do
|
||
|
|
-- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
|
||
|
|
-- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
|
||
|
|
h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
|
||
|
|
fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
|
||
|
|
when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
|
||
|
|
|
||
|
|
-- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
|
||
|
|
m <- getConsoleMode h
|
||
|
|
|
||
|
|
-- VT processing not already enabled?
|
||
|
|
if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0
|
||
|
|
-- https://docs.microsoft.com/en-us/windows/console/setconsolemode
|
||
|
|
then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
|
||
|
|
>> pure (Right False)
|
||
|
|
else pure (Right True)
|
||
|
|
|