summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghc.mk1
-rw-r--r--compiler/main/DynFlags.hs100
-rw-r--r--compiler/main/SysTools/Terminal.hs150
4 files changed, 154 insertions, 98 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index ea9c355010..4875753a1c 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -357,6 +357,7 @@ Library
StaticFlags
StaticPtrTable
SysTools
+ SysTools.Terminal
Elf
TidyPgm
Ctype
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 2b85e42b68..37a026c722 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -532,6 +532,7 @@ compiler_stage2_dll0_MODULES = \
SrcLoc \
StaticFlags \
StringBuffer \
+ SysTools.Terminal \
TcEvidence \
TcRnTypes \
TcType \
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index f1bb6c0dd0..aee5edce85 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------
--
@@ -157,16 +156,6 @@ module DynFlags (
#include "HsVersions.h"
-#if defined mingw32_HOST_OS && !defined WINAPI
-# if defined i386_HOST_ARCH
-# define WINAPI stdcall
-# elif defined x86_64_HOST_ARCH
-# define WINAPI ccall
-# else
-# error unknown architecture
-# endif
-#endif
-
import Platform
import PlatformConstants
import Module
@@ -190,6 +179,7 @@ import Outputable
import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn )
+import SysTools.Terminal ( stderrSupportsAnsiColors )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
@@ -199,7 +189,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
-import Control.Exception (catch, throwIO)
+import Control.Exception (throwIO)
import Data.Ord
import Data.Bits
@@ -216,14 +206,6 @@ import System.Directory
import System.Environment (getEnv)
import System.IO
import System.IO.Error
-#if defined MIN_VERSION_terminfo
-import System.Console.Terminfo (SetupTermError, Terminal, getCapability,
- setupTermFromEnv, termColors)
-import System.Posix (queryTerminal, stdError)
-#elif defined mingw32_HOST_OS
-import System.Environment (lookupEnv)
-import qualified Graphics.Win32 as Win32
-#endif
import Text.ParserCombinators.ReadP hiding (char)
import Text.ParserCombinators.ReadP as R
@@ -1498,84 +1480,6 @@ initDynFlags dflags = do
rtccInfo = refRtccInfo
}
--- | Check if ANSI escape sequences can be used to control color in stderr.
-stderrSupportsAnsiColors :: IO Bool
-stderrSupportsAnsiColors = do
-#if defined MIN_VERSION_terminfo
- queryTerminal stdError `andM` do
- (termSupportsColors <$> setupTermFromEnv)
- `catch` \ (_ :: SetupTermError) ->
- pure False
-
- where
-
- andM :: Monad m => m Bool -> m Bool -> m Bool
- andM mx my = do
- x <- mx
- if x
- then my
- else pure x
-
- termSupportsColors :: Terminal -> Bool
- termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0
-
-#elif defined mingw32_HOST_OS
- foldl1 orM
- [ (/= "") <$> getEnvLM "ANSICON"
- , (== "on") <$> getEnvLM "ConEmuANSI"
- , (== "xterm") <$> getEnvLM "TERM"
- , do
- h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE
- mode <- getConsoleMode h
- if modeHasVTP mode
- then pure True
- else do
- setConsoleMode h (modeAddVTP mode)
- modeHasVTP <$> getConsoleMode h
- `catch` \ (_ :: IOError) ->
- pure False
- ]
-
- where
-
- orM :: Monad m => m Bool -> m Bool -> m Bool
- orM mx my = do
- x <- mx
- if x
- then pure x
- else my
-
- getEnvLM :: String -> IO String
- getEnvLM name = map toLower . fromMaybe "" <$> lookupEnv name
-
- modeHasVTP :: Win32.DWORD -> Bool
- modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
-
- modeAddVTP :: Win32.DWORD -> Win32.DWORD
- modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
-
-eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD
-eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
-
-getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD
-getConsoleMode h = with 64 $ \ mode -> do
- Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode)
- peek mode
-
-setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO ()
-setConsoleMode h mode = do
- Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode)
-
-foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode
- :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL
-
-foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode
- :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL
-
-#else
- pure False
-#endif
-
-- | The normal 'DynFlags'. Note that they are not suitable for use in this form
-- and must be fully initialized by 'GHC.runGhc' first.
defaultDynFlags :: Settings -> DynFlags
diff --git a/compiler/main/SysTools/Terminal.hs b/compiler/main/SysTools/Terminal.hs
new file mode 100644
index 0000000000..b3bf6e651d
--- /dev/null
+++ b/compiler/main/SysTools/Terminal.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module SysTools.Terminal (stderrSupportsAnsiColors) where
+#if defined MIN_VERSION_terminfo
+import Control.Exception (catch)
+import Data.Maybe (fromMaybe)
+import System.Console.Terminfo (SetupTermError, Terminal, getCapability,
+ setupTermFromEnv, termColors)
+import System.Posix (queryTerminal, stdError)
+#elif defined mingw32_HOST_OS
+import Control.Exception (catch, try)
+import Data.Bits ((.|.), (.&.))
+import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
+import Foreign (FunPtr, Ptr, allocaBytes, castPtrToFunPtr,
+ peek, plusPtr, sizeOf, with)
+import Foreign.C (CInt(..), CWchar, peekCWStringLen)
+import qualified Graphics.Win32 as Win32
+import qualified System.Win32 as Win32
+#endif
+
+#if defined mingw32_HOST_OS && !defined WINAPI
+# if defined i386_HOST_ARCH
+# define WINAPI stdcall
+# elif defined x86_64_HOST_ARCH
+# define WINAPI ccall
+# else
+# error unknown architecture
+# endif
+#endif
+
+-- | Check if ANSI escape sequences can be used to control color in stderr.
+stderrSupportsAnsiColors :: IO Bool
+stderrSupportsAnsiColors = do
+#if defined MIN_VERSION_terminfo
+ queryTerminal stdError `andM` do
+ (termSupportsColors <$> setupTermFromEnv)
+ `catch` \ (_ :: SetupTermError) ->
+ pure False
+
+ where
+
+ andM :: Monad m => m Bool -> m Bool -> m Bool
+ andM mx my = do
+ x <- mx
+ if x
+ then my
+ else pure x
+
+ termSupportsColors :: Terminal -> Bool
+ termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0
+
+#elif defined mingw32_HOST_OS
+ h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE
+ `catch` \ (_ :: IOError) ->
+ pure Win32.nullHANDLE
+ if h == Win32.nullHANDLE
+ then pure False
+ else do
+ eMode <- try (getConsoleMode h)
+ case eMode of
+ Left (_ :: IOError) -> queryCygwinTerminal h
+ Right mode
+ | modeHasVTP mode -> pure True
+ | otherwise -> enableVTP h mode
+
+ where
+
+ queryCygwinTerminal :: Win32.HANDLE -> IO Bool
+ queryCygwinTerminal h = do
+ fileType <- Win32.getFileType h
+ if fileType /= Win32.fILE_TYPE_PIPE
+ then pure False
+ else do
+ fn <- getFileNameByHandle h
+ pure (("\\cygwin-" `isPrefixOf` fn || "\\msys-" `isPrefixOf` fn) &&
+ "-pty" `isInfixOf` fn &&
+ "-master" `isSuffixOf` fn)
+ `catch` \ (_ :: IOError) ->
+ pure False
+
+ enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool
+ enableVTP h mode = do
+ setConsoleMode h (modeAddVTP mode)
+ modeHasVTP <$> getConsoleMode h
+ `catch` \ (_ :: IOError) ->
+ pure False
+
+ modeHasVTP :: Win32.DWORD -> Bool
+ modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0
+
+ modeAddVTP :: Win32.DWORD -> Win32.DWORD
+ modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING
+
+eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD
+eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
+
+getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD
+getConsoleMode h = with 64 $ \ mode -> do
+ Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode)
+ peek mode
+
+setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO ()
+setConsoleMode h mode = do
+ Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode)
+
+foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode
+ :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL
+
+foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode
+ :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL
+
+fileNameInfo :: CInt
+fileNameInfo = 2
+
+mAX_PATH :: Num a => a
+mAX_PATH = 260
+
+getFileNameByHandle :: Win32.HANDLE -> IO String
+getFileNameByHandle h = do
+ let sizeOfDWORD = sizeOf (undefined :: Win32.DWORD)
+ let sizeOfWchar = sizeOf (undefined :: CWchar)
+ -- note: implicitly assuming that DWORD has stronger alignment than wchar_t
+ let bufSize = sizeOfDWORD + mAX_PATH * sizeOfWchar
+ allocaBytes bufSize $ \ buf -> do
+ getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize)
+ len :: Win32.DWORD <- peek buf
+ let len' = fromIntegral len `div` sizeOfWchar
+ peekCWStringLen (buf `plusPtr` sizeOfDWORD, min len' mAX_PATH)
+
+getFileInformationByHandleEx
+ :: Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO ()
+getFileInformationByHandleEx h cls buf bufSize = do
+ lib <- Win32.getModuleHandle (Just "kernel32.dll")
+ ptr <- Win32.getProcAddress lib "GetFileInformationByHandleEx"
+ let c_GetFileInformationByHandleEx =
+ mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr)
+ Win32.failIfFalse_ "getFileInformationByHandleEx"
+ (c_GetFileInformationByHandleEx h cls buf bufSize)
+
+type F_GetFileInformationByHandleEx a =
+ Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO Win32.BOOL
+
+foreign import WINAPI "dynamic"
+ mk_GetFileInformationByHandleEx
+ :: FunPtr (F_GetFileInformationByHandleEx a)
+ -> F_GetFileInformationByHandleEx a
+
+#else
+ pure False
+#endif
View Lorry Controller Status