ansi-terminal-0.6.3.1/System/0000755000000000000000000000000012253056123014073 5ustar0000000000000000ansi-terminal-0.6.3.1/System/Console/0000755000000000000000000000000013111265532015475 5ustar0000000000000000ansi-terminal-0.6.3.1/System/Console/ANSI/0000755000000000000000000000000013111265532016227 5ustar0000000000000000ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/0000755000000000000000000000000013112042701017651 5ustar0000000000000000ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Emulator/0000755000000000000000000000000013111265532021451 5ustar0000000000000000ansi-terminal-0.6.3.1/includes/0000755000000000000000000000000013111265532014415 5ustar0000000000000000ansi-terminal-0.6.3.1/System/Console/ANSI.hs0000644000000000000000000000547113111265532016572 0ustar0000000000000000-- | Provides ANSI terminal support for ANSI terminal software running on a -- Unix-like operating system or on a Windows operating system (where supported) -- or on other Windows operating systems where the terminal in use is not -- ANSI-enabled. -- -- The ANSI escape codes are described at and provide a rich range of -- functionality for terminal control, which includes: -- -- * Colored text output, with control over both foreground and background colors -- -- * Hiding or showing the cursor -- -- * Moving the cursor around -- -- * Clearing parts of the screen -- -- The most frequently used parts of this ANSI command set are exposed with a platform independent interface by -- this module. Every function exported comes in three flavours: -- -- * Vanilla: has an @IO ()@ type and doesn't take a @Handle@. This just outputs the ANSI command directly on -- to the terminal corresponding to stdout. Commands issued like this should work as you expect on both Windows -- and Unix. -- -- * Chocolate: has an @IO ()@ type but takes a @Handle@. This outputs the ANSI command on the terminal corresponding -- to the supplied handle. Commands issued like this should also work as you expect on both Windows and Unix. -- -- * Strawberry: has a @String@ type and just consists of an escape code which can be added to any other bit of text -- before being output. This version of the API is often convenient to use, -- but will not work on Windows operating systems where the terminal in use -- is not ANSI-enabled (such as those before Windows 10 Threshold 2). On -- versions of Windows where the terminal in use is not ANSI-enabled, these -- codes will always be the empty string, so it is possible to use them -- portably for e.g. coloring console output on the understanding that you -- will only see colors if you are running on an operating system that is -- Unix-like or is a version of Windows where the terminal in use is ANSI- -- enabled. -- -- Example: -- -- > -- Set colors and write some text in those colors. -- > sgrExample :: IO () -- > sgrExample = do -- > setSGR [SetColor Foreground Vivid Red] -- > setSGR [SetColor Background Vivid Blue] -- > putStr "Red-On-Blue" -- > setSGR [Reset] -- > putStr "White-On-Black" -- -- For many more examples, see the project's extensive -- file. #if defined(WINDOWS) module System.Console.ANSI ( module System.Console.ANSI.Windows ) where import System.Console.ANSI.Windows #elif defined(UNIX) module System.Console.ANSI ( module System.Console.ANSI.Unix ) where import System.Console.ANSI.Unix #else #error Unsupported platform for the ansi-terminal package #endif ansi-terminal-0.6.3.1/System/Console/ANSI/Types.hs0000644000000000000000000000443312776413432017705 0ustar0000000000000000-- | Types used to represent SELECT GRAPHIC RENDITION (SGR) aspects. module System.Console.ANSI.Types ( SGR (..) , ConsoleLayer (..) , Color (..) , ColorIntensity (..) , ConsoleIntensity (..) , Underlining (..) , BlinkSpeed (..) ) where import Data.Ix -- | ANSI colors: come in various intensities, which are controlled by 'ColorIntensity' data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI colors come in two intensities data ColorIntensity = Dull | Vivid deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI colors can be set on two different layers data ConsoleLayer = Foreground | Background deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI blink speeds: values other than 'NoBlink' are not widely supported data BlinkSpeed = SlowBlink -- ^ Less than 150 blinks per minute | RapidBlink -- ^ More than 150 blinks per minute | NoBlink deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI text underlining data Underlining = SingleUnderline | DoubleUnderline -- ^ Not widely supported | NoUnderline deriving (Eq, Ord, Bounded ,Enum, Show, Read, Ix) -- | ANSI general console intensity: usually treated as setting the font style (e.g. 'BoldIntensity' causes text to be bold) data ConsoleIntensity = BoldIntensity | FaintIntensity -- ^ Not widely supported: sometimes treated as concealing text | NormalIntensity deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI Select Graphic Rendition command data SGR = Reset | SetConsoleIntensity ConsoleIntensity | SetItalicized Bool -- ^ Not widely supported: sometimes treated as swapping foreground and background | SetUnderlining Underlining | SetBlinkSpeed BlinkSpeed | SetVisible Bool -- ^ Not widely supported | SetSwapForegroundBackground Bool | SetColor ConsoleLayer ColorIntensity Color deriving (Eq, Ord, Show, Read) ansi-terminal-0.6.3.1/System/Console/ANSI/Codes.hs0000644000000000000000000001403313111265532017621 0ustar0000000000000000-- | Functions that return 'String' values containing codes in accordance with: -- (1) standard ECMA-48 Control Functions for Coded Character Sets (5th edition, -- 1991); or (2) in the case of 'setTitleCode', the XTerm control sequence. -- -- The reference used for the codes in this module was -- . -- -- If module "System.Console.ANSI" is also imported, this module is intended to -- be imported qualified, to avoid name clashes with functions which return \"\" -- when Windows ANSI terminal support is emulated. e.g. -- -- > import qualified System.Console.ANSI.Codes as ANSI -- module System.Console.ANSI.Codes ( -- * Basic data types module System.Console.ANSI.Types -- * Cursor movement by character , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode -- * Cursor movement by line , cursorUpLineCode, cursorDownLineCode -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode , clearFromCursorToLineBeginningCode, clearLineCode -- * Scrolling the screen , scrollPageUpCode, scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGRCode -- * Cursor visibilty changes , hideCursorCode, showCursorCode -- * Changing the title -- | Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the -- right direction on xterm title setting on haskell-cafe. The "0" -- signifies that both the title and "icon" text should be set: i.e. the -- text for the window in the Start bar (or similar) as well as that in -- the actual window title. This is chosen for consistent behaviour -- between Unixes and Windows. , setTitleCode -- * Utilities , colorToCode, csi, sgrToCode ) where import Data.List (intersperse) import System.Console.ANSI.Types -- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int', -- returns the control sequence comprising the control function CONTROL -- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \';\') -- and ending with the @controlFunction@ character(s) that identifies the -- control function. csi :: [Int] -- ^ List of parameters for the control sequence -> String -- ^ Character(s) that identify the control function -> String csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code -- | 'colorToCode' @color@ returns the 0-based index of the color (one of the -- eight colors in the standard). colorToCode :: Color -> Int colorToCode color = case color of Black -> 0 Red -> 1 Green -> 2 Yellow -> 3 Blue -> 4 Magenta -> 5 Cyan -> 6 White -> 7 -- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION -- (SGR) aspect identified by @sgr@. sgrToCode :: SGR -- ^ The SGR aspect -> Int sgrToCode sgr = case sgr of Reset -> 0 SetConsoleIntensity intensity -> case intensity of BoldIntensity -> 1 FaintIntensity -> 2 NormalIntensity -> 22 SetItalicized True -> 3 SetItalicized False -> 23 SetUnderlining underlining -> case underlining of SingleUnderline -> 4 DoubleUnderline -> 21 NoUnderline -> 24 SetBlinkSpeed blink_speed -> case blink_speed of SlowBlink -> 5 RapidBlink -> 6 NoBlink -> 25 SetVisible False -> 8 SetVisible True -> 28 SetSwapForegroundBackground True -> 7 SetSwapForegroundBackground False -> 27 SetColor Foreground Dull color -> 30 + colorToCode color SetColor Foreground Vivid color -> 90 + colorToCode color SetColor Background Dull color -> 40 + colorToCode color SetColor Background Vivid color -> 100 + colorToCode color cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: Int -- ^ Number of lines or characters to move -> String cursorUpCode n = csi [n] "A" cursorDownCode n = csi [n] "B" cursorForwardCode n = csi [n] "C" cursorBackwardCode n = csi [n] "D" cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move -> String cursorDownLineCode n = csi [n] "E" cursorUpLineCode n = csi [n] "F" setCursorColumnCode :: Int -- ^ 0-based column to move to -> String setCursorColumnCode n = csi [n + 1] "G" setCursorPositionCode :: Int -- ^ 0-based row to move to -> Int -- ^ 0-based column to move to -> String setCursorPositionCode n m = csi [n + 1, m + 1] "H" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String clearFromCursorToScreenEndCode = csi [0] "J" clearFromCursorToScreenBeginningCode = csi [1] "J" clearScreenCode = csi [2] "J" clearFromCursorToLineEndCode = csi [0] "K" clearFromCursorToLineBeginningCode = csi [1] "K" clearLineCode = csi [2] "K" scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by -> String scrollPageUpCode n = csi [n] "S" scrollPageDownCode n = csi [n] "T" setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the -- current console SGR mode. An empty list of commands is -- equivalent to the list @[Reset]@. Commands are applied -- left to right. -> String setSGRCode sgrs = csi (map sgrToCode sgrs) "m" hideCursorCode, showCursorCode :: String hideCursorCode = csi [] "?25l" showCursorCode = csi [] "?25h" -- | XTerm control sequence to set the Icon Name and Window Title. setTitleCode :: String -- ^ New Icon Name and Window Title -> String setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007" ansi-terminal-0.6.3.1/System/Console/ANSI/Windows.hs0000644000000000000000000001400113111265532020211 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as U import System.Console.ANSI.Windows.Detect (isANSIEnabled) import qualified System.Console.ANSI.Windows.Emulator as E import System.IO (Handle, hIsTerminalDevice, stdout) #include "Common-Include.hs" -- * Cursor movement by character hCursorUp = if isANSIEnabled then U.hCursorUp else E.hCursorUp hCursorDown = if isANSIEnabled then U.hCursorDown else E.hCursorDown hCursorForward = if isANSIEnabled then U.hCursorForward else E.hCursorForward hCursorBackward = if isANSIEnabled then U.hCursorBackward else E.hCursorBackward cursorUpCode :: Int -> String cursorUpCode = if isANSIEnabled then U.cursorUpCode else E.cursorUpCode cursorDownCode :: Int -> String cursorDownCode = if isANSIEnabled then U.cursorDownCode else E.cursorDownCode cursorForwardCode :: Int -> String cursorForwardCode = if isANSIEnabled then U.cursorForwardCode else E.cursorForwardCode cursorBackwardCode :: Int -> String cursorBackwardCode = if isANSIEnabled then U.cursorBackwardCode else E.cursorBackwardCode -- * Cursor movement by line hCursorUpLine = if isANSIEnabled then U.hCursorUpLine else E.hCursorUpLine hCursorDownLine = if isANSIEnabled then U.hCursorDownLine else E.hCursorDownLine cursorUpLineCode :: Int -> String cursorUpLineCode = if isANSIEnabled then U.cursorUpLineCode else E.cursorUpLineCode cursorDownLineCode :: Int -> String cursorDownLineCode = if isANSIEnabled then U.cursorDownLineCode else E.cursorDownLineCode -- * Directly changing cursor position hSetCursorColumn = if isANSIEnabled then U.hSetCursorColumn else E.hSetCursorColumn setCursorColumnCode :: Int -> String setCursorColumnCode = if isANSIEnabled then U.setCursorColumnCode else E.setCursorColumnCode hSetCursorPosition = if isANSIEnabled then U.hSetCursorPosition else E.hSetCursorPosition setCursorPositionCode :: Int -> Int -> String setCursorPositionCode = if isANSIEnabled then U.setCursorPositionCode else E.setCursorPositionCode -- * Clearing parts of the screen hClearFromCursorToScreenEnd = if isANSIEnabled then U.hClearFromCursorToScreenEnd else E.hClearFromCursorToScreenEnd hClearFromCursorToScreenBeginning = if isANSIEnabled then U.hClearFromCursorToScreenBeginning else E.hClearFromCursorToScreenBeginning hClearScreen = if isANSIEnabled then U.hClearScreen else E.hClearScreen clearFromCursorToScreenEndCode :: String clearFromCursorToScreenEndCode = if isANSIEnabled then U.clearFromCursorToScreenEndCode else E.clearFromCursorToScreenEndCode clearFromCursorToScreenBeginningCode :: String clearFromCursorToScreenBeginningCode = if isANSIEnabled then U.clearFromCursorToScreenBeginningCode else E.clearFromCursorToScreenBeginningCode clearScreenCode :: String clearScreenCode = if isANSIEnabled then U.clearScreenCode else E.clearScreenCode hClearFromCursorToLineEnd = if isANSIEnabled then U.hClearFromCursorToLineEnd else E.hClearFromCursorToLineEnd hClearFromCursorToLineBeginning = if isANSIEnabled then U.hClearFromCursorToLineBeginning else E.hClearFromCursorToLineBeginning hClearLine = if isANSIEnabled then U.hClearLine else E.hClearLine clearFromCursorToLineEndCode :: String clearFromCursorToLineEndCode = if isANSIEnabled then U.clearFromCursorToLineEndCode else E.clearFromCursorToLineEndCode clearFromCursorToLineBeginningCode :: String clearFromCursorToLineBeginningCode = if isANSIEnabled then U.clearFromCursorToLineBeginningCode else E.clearFromCursorToLineBeginningCode clearLineCode :: String clearLineCode = if isANSIEnabled then U.clearLineCode else E.clearLineCode -- * Scrolling the screen hScrollPageUp = if isANSIEnabled then U.hScrollPageUp else E.hScrollPageUp hScrollPageDown = if isANSIEnabled then U.hScrollPageDown else E.hScrollPageDown scrollPageUpCode :: Int -> String scrollPageUpCode = if isANSIEnabled then U.scrollPageUpCode else E.scrollPageUpCode scrollPageDownCode :: Int -> String scrollPageDownCode = if isANSIEnabled then U.scrollPageDownCode else E.scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff -- -- The following SGR codes are NOT implemented by Windows 10 Threshold 2: -- 2 SetConsoleIntensity FaintIntensity -- 3 SetItalicized True -- 5 SetBlinkSpeed SlowBlink -- 6 SetBlinkSpeed RapidBlink -- 8 SetVisible False -- 21 SetUnderlining DoubleUnderline -- 23 SetItalicized False -- 25 SetBlinkSpeed NoBlink -- 28 SetVisible True hSetSGR = if isANSIEnabled then U.hSetSGR else E.hSetSGR setSGRCode :: [SGR] -> String setSGRCode = if isANSIEnabled then U.setSGRCode else E.setSGRCode -- * Cursor visibilty changes hHideCursor = if isANSIEnabled then U.hHideCursor else E.hHideCursor hShowCursor = if isANSIEnabled then U.hShowCursor else E.hShowCursor hideCursorCode :: String hideCursorCode = if isANSIEnabled then U.hideCursorCode else E.hideCursorCode showCursorCode :: String showCursorCode = if isANSIEnabled then U.showCursorCode else E.showCursorCode -- * Changing the title hSetTitle = if isANSIEnabled then U.hSetTitle else E.hSetTitle setTitleCode :: String -> String setTitleCode = if isANSIEnabled then U.setTitleCode else E.setTitleCode ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Detect.hs0000644000000000000000000000500413111265532021424 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows.Detect ( isANSIEnabled ) where import Control.Exception (SomeException(..), throwIO, try) import Data.Bits ((.|.)) import System.Console.ANSI.Windows.Foreign (ConsoleException(..), DWORD, eNABLE_VIRTUAL_TERMINAL_PROCESSING, getConsoleMode, getStdHandle, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, sTD_OUTPUT_HANDLE) -- 'lookupEnv' is not available until base-4.6.0.0 (GHC 7.6.1) import System.Environment.Compat (lookupEnv) import System.IO.Unsafe (unsafePerformIO) -- This function assumes that once it is first established whether or not the -- Windows console is ANSI-enabled, that will not change. {-# NOINLINE isANSIEnabled #-} isANSIEnabled :: Bool isANSIEnabled = unsafePerformIO safeIsANSIEnabled -- This function takes the following approach. If the environment variable TERM -- exists and is not set to 'dumb' or 'msys' (see below), it assumes the console -- is ANSI-enabled. Otherwise, it tries to enable virtual terminal processing. -- If that fails, it assumes the console is not ANSI-enabled. -- -- In Git Shell, if Command Prompt or PowerShell are used, the environment -- variable TERM is set to 'msys'. If 'Git Bash' (mintty) is used, TERM is set -- to 'xterm' (by default). safeIsANSIEnabled :: IO Bool safeIsANSIEnabled = do result <- lookupEnv "TERM" case result of Just "dumb" -> return False Just "msys" -> doesEnableANSIOutSucceed Just _ -> return True Nothing -> doesEnableANSIOutSucceed -- This function returns whether or not an attempt to enable virtual terminal -- processing succeeded, in the IO monad. doesEnableANSIOutSucceed :: IO Bool doesEnableANSIOutSucceed = do result <- try enableANSIOut :: IO (Either SomeException ()) case result of Left _ -> return False Right () -> return True -- This function tries to enable virtual terminal processing on the standard -- output and throws an exception if it cannot. enableANSIOut :: IO () enableANSIOut = do hOut <- getValidStdHandle sTD_OUTPUT_HANDLE mOut <- getConsoleMode hOut let mOut' = mOut .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING setConsoleMode hOut mOut' -- This function tries to get a valid standard handle and throws an exception if -- it cannot. getValidStdHandle :: DWORD -> IO HANDLE getValidStdHandle nStdHandle = do h <- getStdHandle nStdHandle if h == iNVALID_HANDLE_VALUE || h == nullHANDLE then throwIO $ ConsoleException 6 -- Invalid Handle else return h ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Emulator.hs0000644000000000000000000002670013111265532022012 0ustar0000000000000000module System.Console.ANSI.Windows.Emulator ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as Unix import System.Console.ANSI.Windows.Foreign import System.Console.ANSI.Windows.Emulator.Codes import System.IO import Control.Exception (catchJust) import Data.Bits import Data.List #include "Common-Include.hs" withHandle :: Handle -> (HANDLE -> IO a) -> IO a withHandle handle action = do -- It's VERY IMPORTANT that we flush before issuing any sort of Windows API call to change the console -- because on Windows the arrival of API-initiated state changes is not necessarily synchronised with that -- of the text they are attempting to modify. hFlush handle withHandleToHANDLE handle action -- Unfortunately, the emulator is not perfect. In particular, it has a tendency to die with exceptions about -- invalid handles when it is used with certain Windows consoles (e.g. mintty, terminator, or cygwin sshd). -- -- This happens because in those environments the stdout family of handles are not actually associated with -- a real console. -- -- My observation is that every time I've seen this in practice, the handle we have instead of the actual console -- handle is there so that the terminal supports ANSI escape codes. So 99% of the time, the correct thing to do is -- just to fall back on the Unix module to output the ANSI codes and hope for the best. emulatorFallback :: IO a -> IO a -> IO a emulatorFallback fallback first_try = catchJust invalidHandle first_try (const fallback) where invalidHandle (ConsoleException 6) = Just () -- 6 is the Windows error code for invalid handles invalidHandle (_) = Nothing adjustCursorPosition :: HANDLE -> (SHORT -> SHORT -> SHORT) -> (SHORT -> SHORT -> SHORT) -> IO () adjustCursorPosition handle change_x change_y = do screen_buffer_info <- getConsoleScreenBufferInfo handle let window = csbi_window screen_buffer_info (COORD x y) = csbi_cursor_position screen_buffer_info cursor_pos' = COORD (change_x (rect_left window) x) (change_y (rect_top window) y) setConsoleCursorPosition handle cursor_pos' hCursorUp h n = emulatorFallback (Unix.hCursorUp h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x) (\_ y -> y - fromIntegral n) hCursorDown h n = emulatorFallback (Unix.hCursorDown h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x) (\_ y -> y + fromIntegral n) hCursorForward h n = emulatorFallback (Unix.hCursorForward h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x + fromIntegral n) (\_ y -> y) hCursorBackward h n = emulatorFallback (Unix.hCursorBackward h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x - fromIntegral n) (\_ y -> y) adjustLine :: HANDLE -> (SHORT -> SHORT -> SHORT) -> IO () adjustLine handle change_y = adjustCursorPosition handle (\window_left _ -> window_left) change_y hCursorDownLine h n = emulatorFallback (Unix.hCursorDownLine h n) $ withHandle h $ \handle -> adjustLine handle (\_ y -> y + fromIntegral n) hCursorUpLine h n = emulatorFallback (Unix.hCursorUpLine h n) $ withHandle h $ \handle -> adjustLine handle (\_ y -> y - fromIntegral n) hSetCursorColumn h x = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) hSetCursorPosition h y x = emulatorFallback (Unix.hSetCursorPosition h y x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\window_top _ -> window_top + fromIntegral y) clearChar :: WCHAR clearChar = charToWCHAR ' ' clearAttribute :: WORD clearAttribute = 0 hClearScreenFraction :: HANDLE -> (SMALL_RECT -> COORD -> (DWORD, COORD)) -> IO () hClearScreenFraction handle fraction_finder = do screen_buffer_info <- getConsoleScreenBufferInfo handle let window = csbi_window screen_buffer_info cursor_pos = csbi_cursor_position screen_buffer_info (fill_length, fill_cursor_pos) = fraction_finder window cursor_pos fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos fillConsoleOutputAttribute handle clearAttribute fill_length fill_cursor_pos return () hClearFromCursorToScreenEnd h = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral fill_length, cursor_pos) where size_x = rect_width window size_y = rect_bottom window - coord_y cursor_pos line_remainder = size_x - coord_x cursor_pos fill_length = size_x * size_y + line_remainder hClearFromCursorToScreenBeginning h = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral fill_length, rect_top_left window) where size_x = rect_width window size_y = coord_y cursor_pos - rect_top window line_remainder = coord_x cursor_pos fill_length = size_x * size_y + line_remainder hClearScreen h = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window _ = (fromIntegral fill_length, rect_top_left window) where size_x = rect_width window size_y = rect_height window fill_length = size_x * size_y hClearFromCursorToLineEnd h = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral (rect_right window - coord_x cursor_pos), cursor_pos) hClearFromCursorToLineBeginning h = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral (coord_x cursor_pos), cursor_pos { coord_x = rect_left window }) hClearLine h = emulatorFallback (Unix.hClearLine h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral (rect_width window), cursor_pos { coord_x = rect_left window }) hScrollPage :: HANDLE -> Int -> IO () hScrollPage handle new_origin_y = do screen_buffer_info <- getConsoleScreenBufferInfo handle let fill = CHAR_INFO clearChar clearAttribute window = csbi_window screen_buffer_info origin = COORD (rect_left window) (rect_top window + fromIntegral new_origin_y) scrollConsoleScreenBuffer handle window Nothing origin fill hScrollPageUp h n = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $ \handle -> hScrollPage handle (negate n) hScrollPageDown h n = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $ \handle -> hScrollPage handle n {-# INLINE applyANSIColorToAttribute #-} applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of Black -> attribute' Red -> attribute' .|. rED Green -> attribute' .|. gREEN Yellow -> attribute' .|. rED .|. gREEN Blue -> attribute' .|. bLUE Magenta -> attribute' .|. rED .|. bLUE Cyan -> attribute' .|. gREEN .|. bLUE White -> attribute' .|. wHITE where wHITE = rED .|. gREEN .|. bLUE attribute' = attribute .&. (complement wHITE) applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute :: Color -> WORD -> WORD applyForegroundANSIColorToAttribute = applyANSIColorToAttribute fOREGROUND_RED fOREGROUND_GREEN fOREGROUND_BLUE applyBackgroundANSIColorToAttribute = applyANSIColorToAttribute bACKGROUND_RED bACKGROUND_GREEN bACKGROUND_BLUE swapForegroundBackgroundColors :: WORD -> WORD swapForegroundBackgroundColors attribute = clean_attribute .|. foreground_attribute' .|. background_attribute' where foreground_attribute = attribute .&. fOREGROUND_INTENSE_WHITE background_attribute = attribute .&. bACKGROUND_INTENSE_WHITE clean_attribute = attribute .&. complement (fOREGROUND_INTENSE_WHITE .|. bACKGROUND_INTENSE_WHITE) foreground_attribute' = background_attribute `shiftR` 4 background_attribute' = foreground_attribute `shiftL` 4 applyANSISGRToAttribute :: SGR -> WORD -> WORD applyANSISGRToAttribute sgr attribute = case sgr of Reset -> fOREGROUND_WHITE SetConsoleIntensity intensity -> case intensity of BoldIntensity -> attribute .|. iNTENSITY FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported NormalIntensity -> attribute .&. (complement iNTENSITY) SetItalicized _ -> attribute -- Not supported SetUnderlining underlining -> case underlining of NoUnderline -> attribute .&. (complement cOMMON_LVB_UNDERSCORE) _ -> attribute .|. cOMMON_LVB_UNDERSCORE -- Not supported, since cOMMON_LVB_UNDERSCORE seems to have no effect SetBlinkSpeed _ -> attribute -- Not supported SetVisible _ -> attribute -- Not supported -- The cOMMON_LVB_REVERSE_VIDEO doesn't actually appear to have any affect on the colors being displayed, so the emulator -- just uses it to carry information and implements the color-swapping behaviour itself. Bit of a hack, I guess :-) SetSwapForegroundBackground True -> -- Check if the color-swapping flag is already set if attribute .&. cOMMON_LVB_REVERSE_VIDEO /= 0 then attribute else swapForegroundBackgroundColors attribute .|. cOMMON_LVB_REVERSE_VIDEO SetSwapForegroundBackground False -> -- Check if the color-swapping flag is already not set if attribute .&. cOMMON_LVB_REVERSE_VIDEO == 0 then attribute else swapForegroundBackgroundColors attribute .&. (complement cOMMON_LVB_REVERSE_VIDEO) SetColor Foreground Dull color -> applyForegroundANSIColorToAttribute color (attribute .&. (complement fOREGROUND_INTENSITY)) SetColor Foreground Vivid color -> applyForegroundANSIColorToAttribute color (attribute .|. fOREGROUND_INTENSITY) SetColor Background Dull color -> applyBackgroundANSIColorToAttribute color (attribute .&. (complement bACKGROUND_INTENSITY)) SetColor Background Vivid color -> applyBackgroundANSIColorToAttribute color (attribute .|. bACKGROUND_INTENSITY) where iNTENSITY = fOREGROUND_INTENSITY hSetSGR h sgr = emulatorFallback (Unix.hSetSGR h sgr) $ withHandle h $ \handle -> do screen_buffer_info <- getConsoleScreenBufferInfo handle let attribute = csbi_attributes screen_buffer_info attribute' = foldl' (flip applyANSISGRToAttribute) attribute -- make [] equivalent to [Reset], as documented (if null sgr then [Reset] else sgr) setConsoleTextAttribute handle attribute' hChangeCursorVisibility :: HANDLE -> Bool -> IO () hChangeCursorVisibility handle cursor_visible = do cursor_info <- getConsoleCursorInfo handle setConsoleCursorInfo handle (cursor_info { cci_cursor_visible = cursor_visible }) hHideCursor h = emulatorFallback (Unix.hHideCursor h) $ withHandle h $ \handle -> hChangeCursorVisibility handle False hShowCursor h = emulatorFallback (Unix.hShowCursor h) $ withHandle h $ \handle -> hChangeCursorVisibility handle True -- Windows only supports setting the terminal title on a process-wide basis, so for now we will -- assume that that is what the user intended. This will fail if they are sending the command -- over e.g. a network link... but that's not really what I'm designing for. hSetTitle h title = emulatorFallback (Unix.hSetTitle h title) $ withTString title $ setConsoleTitle ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Emulator/Codes.hs0000644000000000000000000000536213111265532023050 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows.Emulator.Codes ( -- * Cursor movement by character cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode -- * Cursor movement by line , cursorUpLineCode, cursorDownLineCode -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode , clearFromCursorToLineBeginningCode, clearLineCode -- * Scrolling the screen , scrollPageUpCode, scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGRCode -- * Cursor visibilty changes , hideCursorCode, showCursorCode -- * Changing the title , setTitleCode ) where import System.Console.ANSI.Types cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: Int -- ^ Number of lines or characters to move -> String cursorUpCode _ = "" cursorDownCode _ = "" cursorForwardCode _ = "" cursorBackwardCode _ = "" cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move -> String cursorDownLineCode _ = "" cursorUpLineCode _ = "" setCursorColumnCode :: Int -- ^ 0-based column to move to -> String setCursorColumnCode _ = "" setCursorPositionCode :: Int -- ^ 0-based row to move to -> Int -- ^ 0-based column to move to -> String setCursorPositionCode _ _ = "" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String clearFromCursorToScreenEndCode = "" clearFromCursorToScreenBeginningCode = "" clearScreenCode = "" clearFromCursorToLineEndCode = "" clearFromCursorToLineBeginningCode = "" clearLineCode = "" scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by -> String scrollPageUpCode _ = "" scrollPageDownCode _ = "" setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the -- current console SGR mode. An empty list of commands is -- equivalent to the list @[Reset]@. Commands are applied -- left to right. -> String setSGRCode _ = "" hideCursorCode, showCursorCode :: String hideCursorCode = "" showCursorCode = "" setTitleCode :: String -- ^ New title -> String setTitleCode _ = "" ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Foreign.hs0000644000000000000000000003624513112042701021610 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} -- | "System.Win32.Console" is really very impoverished, so I have had to do all the FFI myself. module System.Console.ANSI.Windows.Foreign ( -- Re-exports from Win32.Types BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, charToWCHAR, COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, rect_width, rect_height, CONSOLE_CURSOR_INFO(..), CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING, fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE, cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE, getStdHandle, getConsoleScreenBufferInfo, getConsoleCursorInfo, getConsoleMode, setConsoleTextAttribute, setConsoleCursorPosition, setConsoleCursorInfo, setConsoleTitle, setConsoleMode, fillConsoleOutputAttribute, fillConsoleOutputCharacter, scrollConsoleScreenBuffer, withTString, withHandleToHANDLE, -- ConsoleException(..) ) where import Foreign.C.Types import Foreign.Marshal import Foreign.Ptr import Foreign.Storable import Data.Bits import Data.Char import System.Win32.Types import Control.Exception (Exception, throw) #if __GLASGOW_HASKELL__ >= 612 import Data.Typeable #endif #if !MIN_VERSION_Win32(2,5,1) import Control.Concurrent.MVar import Foreign.StablePtr import Control.Exception (bracket) #if __GLASGOW_HASKELL__ >= 612 import GHC.IO.Handle.Types (Handle(..), Handle__(..)) import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 import Data.Typeable #else import GHC.IOBase (Handle(..), Handle__(..)) import qualified GHC.IOBase as IOBase (FD) -- Just an Int32 #endif #endif #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall #elif defined(x86_64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch #endif --import System.Console.ANSI.Windows.Foreign.Compat #if !MIN_VERSION_Win32(2,5,0) -- Some Windows types missing from System.Win32 prior version 2.5.0.0 type SHORT = CShort #endif type WCHAR = CWchar charToWCHAR :: Char -> WCHAR charToWCHAR char = fromIntegral (ord char) -- This is a FFI hack. Some of the API calls take a Coord, but that isn't a built-in FFI type so I can't -- use it directly. Instead, I use UNPACKED_COORD and marshal COORDs into this manually. Note that we CAN'T -- just use two SHORTs directly because they get expanded to 4 bytes each instead of just boing 2 lots of 2 -- bytes by the stdcall convention, so linking fails. type UNPACKED_COORD = CInt -- Field packing order determined experimentally: I couldn't immediately find a specification for Windows -- struct layout anywhere. unpackCOORD :: COORD -> UNPACKED_COORD unpackCOORD (COORD x y) = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x) peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) peekAndOffset ptr = do item <- peek ptr return (item, ptr `plusPtr` sizeOf item) pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) pokeAndOffset ptr item = do poke ptr item return (ptr `plusPtr` sizeOf item) data COORD = COORD { coord_x :: SHORT, coord_y :: SHORT } instance Show COORD where show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" instance Storable COORD where sizeOf ~(COORD x y) = sizeOf x + sizeOf y alignment ~(COORD x _) = alignment x peek ptr = do let ptr' = castPtr ptr :: Ptr SHORT x <- peekElemOff ptr' 0 y <- peekElemOff ptr' 1 return (COORD x y) poke ptr (COORD x y) = do let ptr' = castPtr ptr :: Ptr SHORT pokeElemOff ptr' 0 x pokeElemOff ptr' 1 y data SMALL_RECT = SMALL_RECT { rect_top_left :: COORD, rect_bottom_right :: COORD } rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT rect_top = coord_y . rect_top_left rect_left = coord_x . rect_top_left rect_bottom = coord_y . rect_bottom_right rect_right = coord_x . rect_bottom_right rect_width, rect_height :: SMALL_RECT -> SHORT rect_width rect = rect_right rect - rect_left rect + 1 rect_height rect = rect_bottom rect - rect_top rect + 1 instance Show SMALL_RECT where show (SMALL_RECT tl br) = show tl ++ "-" ++ show br instance Storable SMALL_RECT where sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br alignment ~(SMALL_RECT tl _) = alignment tl peek ptr = do let ptr' = castPtr ptr :: Ptr COORD tl <- peekElemOff ptr' 0 br <- peekElemOff ptr' 1 return (SMALL_RECT tl br) poke ptr (SMALL_RECT tl br) = do let ptr' = castPtr ptr :: Ptr COORD pokeElemOff ptr' 0 tl pokeElemOff ptr' 1 br data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO { cci_cursor_size :: DWORD, cci_cursor_visible :: BOOL } deriving (Show) instance Storable CONSOLE_CURSOR_INFO where sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size peek ptr = do (size, ptr') <- peekAndOffset (castPtr ptr) visible <- peek ptr' return (CONSOLE_CURSOR_INFO size visible) poke ptr (CONSOLE_CURSOR_INFO size visible) = do ptr' <- pokeAndOffset (castPtr ptr) size poke ptr' visible data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO { csbi_size :: COORD, csbi_cursor_position :: COORD, csbi_attributes :: WORD, csbi_window :: SMALL_RECT, csbi_maximum_window_size :: COORD } deriving (Show) instance Storable CONSOLE_SCREEN_BUFFER_INFO where sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + sizeOf maximum_window_size alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size peek ptr = do (size, ptr1) <- peekAndOffset (castPtr ptr) (cursor_position, ptr2) <- peekAndOffset ptr1 (attributes, ptr3) <- peekAndOffset ptr2 (window, ptr4) <- peekAndOffset ptr3 maximum_window_size <- peek ptr4 return (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do ptr1 <- pokeAndOffset (castPtr ptr) size ptr2 <- pokeAndOffset ptr1 cursor_position ptr3 <- pokeAndOffset ptr2 attributes ptr4 <- pokeAndOffset ptr3 window poke ptr4 maximum_window_size data CHAR_INFO = CHAR_INFO { ci_char :: WCHAR, ci_attributes :: WORD } deriving (Show) instance Storable CHAR_INFO where sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes alignment ~(CHAR_INFO char _) = alignment char peek ptr = do (char, ptr') <- peekAndOffset (castPtr ptr) attributes <- peek ptr' return (CHAR_INFO char attributes) poke ptr (CHAR_INFO char attributes) = do ptr' <- pokeAndOffset (castPtr ptr) char poke ptr' attributes eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD eNABLE_VIRTUAL_TERMINAL_INPUT = 512 eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 sTD_INPUT_HANDLE = -10 sTD_OUTPUT_HANDLE = -11 sTD_ERROR_HANDLE = -12 fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD fOREGROUND_BLUE = 0x1 fOREGROUND_GREEN = 0x2 fOREGROUND_RED = 0x4 fOREGROUND_INTENSITY = 0x8 bACKGROUND_BLUE = 0x10 bACKGROUND_GREEN = 0x20 bACKGROUND_RED= 0x40 bACKGROUND_INTENSITY = 0x80 cOMMON_LVB_REVERSE_VIDEO = 0x4000 cOMMON_LVB_UNDERSCORE = 0x8000 fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_INTENSE_WHITE :: WORD fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle" getStdHandle :: DWORD -> IO HANDLE foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute" cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo" cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute" cFillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW" cFillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW" cScrollConsoleScreenBuffer :: HANDLE -> Ptr SMALL_RECT -> Ptr SMALL_RECT -> UNPACKED_COORD -> Ptr CHAR_INFO -> IO BOOL data ConsoleException = ConsoleException !ErrCode deriving (Show, Eq, Typeable) instance Exception ConsoleException throwIfFalse :: IO Bool -> IO () throwIfFalse action = do succeeded <- action if not succeeded then getLastError >>= throw . ConsoleException -- TODO: Check if last error is zero for some instructable reason (?) else return () getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do throwIfFalse $ cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info peek ptr_console_screen_buffer_info getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info peek ptr_console_cursor_info getConsoleMode :: HANDLE -> IO DWORD getConsoleMode handle = alloca $ \ptr_mode -> do throwIfFalse $ cGetConsoleMode handle ptr_mode peek ptr_mode setConsoleTextAttribute :: HANDLE -> WORD -> IO () setConsoleTextAttribute handle attributes = throwIfFalse $ cSetConsoleTextAttribute handle attributes setConsoleCursorPosition :: HANDLE -> COORD -> IO () setConsoleCursorPosition handle cursor_position = throwIfFalse $ cSetConsoleCursorPosition handle (unpackCOORD cursor_position) setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO () setConsoleCursorInfo handle console_cursor_info = with console_cursor_info $ \ptr_console_cursor_info -> do throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info setConsoleTitle :: LPCTSTR -> IO () setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title setConsoleMode :: HANDLE -> DWORD -> IO () setConsoleMode handle attributes = throwIfFalse $ cSetConsoleMode handle attributes fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD fillConsoleOutputAttribute handle attribute fill_length write_origin = alloca $ \ptr_chars_written -> do throwIfFalse $ cFillConsoleOutputAttribute handle attribute fill_length (unpackCOORD write_origin) ptr_chars_written peek ptr_chars_written fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD fillConsoleOutputCharacter handle char fill_length write_origin = alloca $ \ptr_chars_written -> do throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length (unpackCOORD write_origin) ptr_chars_written peek ptr_chars_written scrollConsoleScreenBuffer :: HANDLE -> SMALL_RECT -> Maybe SMALL_RECT -> COORD -> CHAR_INFO -> IO () scrollConsoleScreenBuffer handle scroll_rectangle mb_clip_rectangle destination_origin fill = with scroll_rectangle $ \ptr_scroll_rectangle -> maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle -> with fill $ \ptr_fill -> throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill #if !MIN_VERSION_Win32(2,5,1) -- | This bit is all highly dubious. The problem is that we want to output ANSI to arbitrary Handles rather than forcing -- people to use stdout. However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able -- to extract one of those from the Haskell Handle. -- -- This code accomplishes this, albeit at the cost of only being compatible with GHC. -- withHandleToHANDLE was added in Win32-2.5.1.0 withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a withHandleToHANDLE haskell_handle action = -- Create a stable pointer to the Handle. This prevents the garbage collector -- getting to it while we are doing horrible manipulations with it, and hence -- stops it being finalized (and closed). withStablePtr haskell_handle $ const $ do -- Grab the write handle variable from the Handle let write_handle_mvar = case haskell_handle of FileHandle _ handle_mvar -> handle_mvar DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one -- Get the FD from the algebraic data type #if __GLASGOW_HASKELL__ < 612 fd <- fmap haFD $ readMVar write_handle_mvar #else --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev) Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar #endif -- Finally, turn that (C-land) FD into a HANDLE using msvcrt windows_handle <- cget_osfhandle fd -- Do what the user originally wanted action windows_handle -- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah! #if __GLASGOW_HASKELL__ >= 612 foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE #else foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE #endif -- withStablePtr was added in Win32-2.5.1.0 withStablePtr :: a -> (StablePtr a -> IO b) -> IO b withStablePtr value = bracket (newStablePtr value) freeStablePtr #endif ansi-terminal-0.6.3.1/System/Console/ANSI/Unix.hs0000644000000000000000000000253513111265532017513 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Unix ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Codes import System.Console.ANSI.Types import System.IO (Handle, hIsTerminalDevice, hPutStr, stdout) #include "Common-Include.hs" hCursorUp h n = hPutStr h $ cursorUpCode n hCursorDown h n = hPutStr h $ cursorDownCode n hCursorForward h n = hPutStr h $ cursorForwardCode n hCursorBackward h n = hPutStr h $ cursorBackwardCode n hCursorDownLine h n = hPutStr h $ cursorDownLineCode n hCursorUpLine h n = hPutStr h $ cursorUpLineCode n hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode hClearScreen h = hPutStr h clearScreenCode hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode hClearLine h = hPutStr h clearLineCode hScrollPageUp h n = hPutStr h $ scrollPageUpCode n hScrollPageDown h n = hPutStr h $ scrollPageDownCode n hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs hHideCursor h = hPutStr h hideCursorCode hShowCursor h = hPutStr h showCursorCode hSetTitle h title = hPutStr h $ setTitleCode title ansi-terminal-0.6.3.1/System/Console/ANSI/Example.hs0000644000000000000000000001375213111265532020166 0ustar0000000000000000module Main ( main ) where import System.Console.ANSI import System.IO import Control.Concurrent import Control.Monad examples :: [IO ()] examples = [ cursorMovementExample , lineChangeExample , setCursorPositionExample , clearExample , scrollExample , sgrExample , cursorVisibilityExample , titleExample ] main :: IO () main = mapM_ (\example -> resetScreen >> example) examples -- Annex D to Standard ECMA-48 (5th Ed, 1991) identifies that the representation -- of an erased state is implementation-dependent. There may or may not be a -- distinction between a character position in the erased state and one imaging -- SPACE. Consequently, to reset the screen, the default graphic rendition must -- be selected (setSGR [Reset]) before all character positions are put into the -- erased state (clearScreen). resetScreen :: IO () resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 pause :: IO () pause = do hFlush stdout -- 1 second pause threadDelay 1000000 cursorMovementExample :: IO () cursorMovementExample = do putStrLn "Line One" putStr "Line Two" pause -- Line One -- Line Two cursorUp 1 putStr " - Extras" pause -- Line One - Extras -- Line Two cursorBackward 2 putStr "zz" pause -- Line One - Extrzz -- Line Two cursorForward 2 putStr "- And More" pause -- Line One - Extrzz - And More -- Line Two cursorDown 1 putStr "Disconnected" pause -- Line One - Extrzz - And More -- Line Two Disconnected lineChangeExample :: IO () lineChangeExample = do putStrLn "Line One" putStr "Line Two" pause -- Line One -- Line Two cursorUpLine 1 putStr "New Line One" pause -- New Line One -- Line Two cursorDownLine 1 putStr "New Line Two" pause -- New Line One -- New Line Two setCursorPositionExample :: IO () setCursorPositionExample = do putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 0 5 putStr "Foo" pause -- Line Foo -- Line Two setCursorPosition 1 5 putStr "Bar" pause -- Line Foo -- Line Bar setCursorColumn 1 putStr "oaf" pause -- Line Foo -- Loaf Bar clearExample :: IO () clearExample = do putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 0 4 clearFromCursorToScreenEnd pause -- Line resetScreen putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 1 4 clearFromCursorToScreenBeginning pause -- -- Two resetScreen putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two setCursorPosition 0 4 clearFromCursorToLineEnd pause -- Line -- Line Two setCursorPosition 1 4 clearFromCursorToLineBeginning pause -- Line -- Two clearLine pause -- Line clearScreen pause -- scrollExample :: IO () scrollExample = do putStrLn "Line One" putStrLn "Line Two" putStrLn "Line Three" pause -- Line One -- Line Two -- Line Three scrollPageDown 2 pause -- -- -- Line One -- Line Two -- Line Three scrollPageUp 3 pause -- Line Two -- Line Three sgrExample :: IO () sgrExample = do let colors = enumFromTo minBound maxBound :: [Color] forM_ [Foreground, Background] $ \layer -> do forM_ [Dull, Vivid] $ \intensity -> do resetScreen forM_ colors $ \color -> do setSGR [Reset] setSGR [SetColor layer intensity color] putStrLn (show color) pause -- All the colors, 4 times in sequence let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") , (SetConsoleIntensity FaintIntensity, "Faint") , (SetConsoleIntensity NormalIntensity, "Normal") , (SetItalicized True, "Italic") , (SetItalicized False, "No Italics") , (SetUnderlining SingleUnderline, "Single Underline") , (SetUnderlining DoubleUnderline, "Double Underline") , (SetUnderlining NoUnderline, "No Underline") , (SetBlinkSpeed SlowBlink, "Slow Blink") , (SetBlinkSpeed RapidBlink, "Rapid Blink") , (SetBlinkSpeed NoBlink, "No Blink") , (SetVisible False, "Conceal") , (SetVisible True, "Reveal") ] forM_ named_styles $ \(style, name) -> do resetScreen setSGR [style] putStrLn name pause -- Text describing a style displayed in that style in sequence setSGR [SetColor Foreground Vivid Red] setSGR [SetColor Background Vivid Blue] clearScreen >> setCursorPosition 0 0 setSGR [SetSwapForegroundBackground False] putStr "Red-On-Blue" pause -- Red-On-Blue clearScreen >> setCursorPosition 0 0 setSGR [SetSwapForegroundBackground True] putStr "Blue-On-Red" pause -- Blue-On-Red cursorVisibilityExample :: IO () cursorVisibilityExample = do putStr "Cursor Demo" pause -- Cursor Demo| hideCursor pause -- Cursor Demo showCursor pause -- Cursor Demo| titleExample :: IO () titleExample = do putStr "Title Demo" pause -- ~/foo/ - ansi-terminal-ex - 83x70 ------------------------------------ -- Title Demo setTitle "Yup, I'm a new title!" pause -- Yup, I'm a new title! - ansi-terminal-ex - 83x70 --------------------------------------------------- -- Title Demo ansi-terminal-0.6.3.1/System/Console/ANSI.hs0000644000000000000000000000547113111265532016572 0ustar0000000000000000-- | Provides ANSI terminal support for ANSI terminal software running on a -- Unix-like operating system or on a Windows operating system (where supported) -- or on other Windows operating systems where the terminal in use is not -- ANSI-enabled. -- -- The ANSI escape codes are described at and provide a rich range of -- functionality for terminal control, which includes: -- -- * Colored text output, with control over both foreground and background colors -- -- * Hiding or showing the cursor -- -- * Moving the cursor around -- -- * Clearing parts of the screen -- -- The most frequently used parts of this ANSI command set are exposed with a platform independent interface by -- this module. Every function exported comes in three flavours: -- -- * Vanilla: has an @IO ()@ type and doesn't take a @Handle@. This just outputs the ANSI command directly on -- to the terminal corresponding to stdout. Commands issued like this should work as you expect on both Windows -- and Unix. -- -- * Chocolate: has an @IO ()@ type but takes a @Handle@. This outputs the ANSI command on the terminal corresponding -- to the supplied handle. Commands issued like this should also work as you expect on both Windows and Unix. -- -- * Strawberry: has a @String@ type and just consists of an escape code which can be added to any other bit of text -- before being output. This version of the API is often convenient to use, -- but will not work on Windows operating systems where the terminal in use -- is not ANSI-enabled (such as those before Windows 10 Threshold 2). On -- versions of Windows where the terminal in use is not ANSI-enabled, these -- codes will always be the empty string, so it is possible to use them -- portably for e.g. coloring console output on the understanding that you -- will only see colors if you are running on an operating system that is -- Unix-like or is a version of Windows where the terminal in use is ANSI- -- enabled. -- -- Example: -- -- > -- Set colors and write some text in those colors. -- > sgrExample :: IO () -- > sgrExample = do -- > setSGR [SetColor Foreground Vivid Red] -- > setSGR [SetColor Background Vivid Blue] -- > putStr "Red-On-Blue" -- > setSGR [Reset] -- > putStr "White-On-Black" -- -- For many more examples, see the project's extensive -- file. #if defined(WINDOWS) module System.Console.ANSI ( module System.Console.ANSI.Windows ) where import System.Console.ANSI.Windows #elif defined(UNIX) module System.Console.ANSI ( module System.Console.ANSI.Unix ) where import System.Console.ANSI.Unix #else #error Unsupported platform for the ansi-terminal package #endif ansi-terminal-0.6.3.1/System/Console/ANSI/Codes.hs0000644000000000000000000001403313111265532017621 0ustar0000000000000000-- | Functions that return 'String' values containing codes in accordance with: -- (1) standard ECMA-48 Control Functions for Coded Character Sets (5th edition, -- 1991); or (2) in the case of 'setTitleCode', the XTerm control sequence. -- -- The reference used for the codes in this module was -- . -- -- If module "System.Console.ANSI" is also imported, this module is intended to -- be imported qualified, to avoid name clashes with functions which return \"\" -- when Windows ANSI terminal support is emulated. e.g. -- -- > import qualified System.Console.ANSI.Codes as ANSI -- module System.Console.ANSI.Codes ( -- * Basic data types module System.Console.ANSI.Types -- * Cursor movement by character , cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode -- * Cursor movement by line , cursorUpLineCode, cursorDownLineCode -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode , clearFromCursorToLineBeginningCode, clearLineCode -- * Scrolling the screen , scrollPageUpCode, scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGRCode -- * Cursor visibilty changes , hideCursorCode, showCursorCode -- * Changing the title -- | Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the -- right direction on xterm title setting on haskell-cafe. The "0" -- signifies that both the title and "icon" text should be set: i.e. the -- text for the window in the Start bar (or similar) as well as that in -- the actual window title. This is chosen for consistent behaviour -- between Unixes and Windows. , setTitleCode -- * Utilities , colorToCode, csi, sgrToCode ) where import Data.List (intersperse) import System.Console.ANSI.Types -- | 'csi' @parameters controlFunction@, where @parameters@ is a list of 'Int', -- returns the control sequence comprising the control function CONTROL -- SEQUENCE INTRODUCER (CSI) followed by the parameter(s) (separated by \';\') -- and ending with the @controlFunction@ character(s) that identifies the -- control function. csi :: [Int] -- ^ List of parameters for the control sequence -> String -- ^ Character(s) that identify the control function -> String csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code -- | 'colorToCode' @color@ returns the 0-based index of the color (one of the -- eight colors in the standard). colorToCode :: Color -> Int colorToCode color = case color of Black -> 0 Red -> 1 Green -> 2 Yellow -> 3 Blue -> 4 Magenta -> 5 Cyan -> 6 White -> 7 -- | 'sgrToCode' @sgr@ returns the parameter of the SELECT GRAPHIC RENDITION -- (SGR) aspect identified by @sgr@. sgrToCode :: SGR -- ^ The SGR aspect -> Int sgrToCode sgr = case sgr of Reset -> 0 SetConsoleIntensity intensity -> case intensity of BoldIntensity -> 1 FaintIntensity -> 2 NormalIntensity -> 22 SetItalicized True -> 3 SetItalicized False -> 23 SetUnderlining underlining -> case underlining of SingleUnderline -> 4 DoubleUnderline -> 21 NoUnderline -> 24 SetBlinkSpeed blink_speed -> case blink_speed of SlowBlink -> 5 RapidBlink -> 6 NoBlink -> 25 SetVisible False -> 8 SetVisible True -> 28 SetSwapForegroundBackground True -> 7 SetSwapForegroundBackground False -> 27 SetColor Foreground Dull color -> 30 + colorToCode color SetColor Foreground Vivid color -> 90 + colorToCode color SetColor Background Dull color -> 40 + colorToCode color SetColor Background Vivid color -> 100 + colorToCode color cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: Int -- ^ Number of lines or characters to move -> String cursorUpCode n = csi [n] "A" cursorDownCode n = csi [n] "B" cursorForwardCode n = csi [n] "C" cursorBackwardCode n = csi [n] "D" cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move -> String cursorDownLineCode n = csi [n] "E" cursorUpLineCode n = csi [n] "F" setCursorColumnCode :: Int -- ^ 0-based column to move to -> String setCursorColumnCode n = csi [n + 1] "G" setCursorPositionCode :: Int -- ^ 0-based row to move to -> Int -- ^ 0-based column to move to -> String setCursorPositionCode n m = csi [n + 1, m + 1] "H" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String clearFromCursorToScreenEndCode = csi [0] "J" clearFromCursorToScreenBeginningCode = csi [1] "J" clearScreenCode = csi [2] "J" clearFromCursorToLineEndCode = csi [0] "K" clearFromCursorToLineBeginningCode = csi [1] "K" clearLineCode = csi [2] "K" scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by -> String scrollPageUpCode n = csi [n] "S" scrollPageDownCode n = csi [n] "T" setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the -- current console SGR mode. An empty list of commands is -- equivalent to the list @[Reset]@. Commands are applied -- left to right. -> String setSGRCode sgrs = csi (map sgrToCode sgrs) "m" hideCursorCode, showCursorCode :: String hideCursorCode = csi [] "?25l" showCursorCode = csi [] "?25h" -- | XTerm control sequence to set the Icon Name and Window Title. setTitleCode :: String -- ^ New Icon Name and Window Title -> String setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007" ansi-terminal-0.6.3.1/System/Console/ANSI/Types.hs0000644000000000000000000000443312776413432017705 0ustar0000000000000000-- | Types used to represent SELECT GRAPHIC RENDITION (SGR) aspects. module System.Console.ANSI.Types ( SGR (..) , ConsoleLayer (..) , Color (..) , ColorIntensity (..) , ConsoleIntensity (..) , Underlining (..) , BlinkSpeed (..) ) where import Data.Ix -- | ANSI colors: come in various intensities, which are controlled by 'ColorIntensity' data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI colors come in two intensities data ColorIntensity = Dull | Vivid deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI colors can be set on two different layers data ConsoleLayer = Foreground | Background deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI blink speeds: values other than 'NoBlink' are not widely supported data BlinkSpeed = SlowBlink -- ^ Less than 150 blinks per minute | RapidBlink -- ^ More than 150 blinks per minute | NoBlink deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI text underlining data Underlining = SingleUnderline | DoubleUnderline -- ^ Not widely supported | NoUnderline deriving (Eq, Ord, Bounded ,Enum, Show, Read, Ix) -- | ANSI general console intensity: usually treated as setting the font style (e.g. 'BoldIntensity' causes text to be bold) data ConsoleIntensity = BoldIntensity | FaintIntensity -- ^ Not widely supported: sometimes treated as concealing text | NormalIntensity deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) -- | ANSI Select Graphic Rendition command data SGR = Reset | SetConsoleIntensity ConsoleIntensity | SetItalicized Bool -- ^ Not widely supported: sometimes treated as swapping foreground and background | SetUnderlining Underlining | SetBlinkSpeed BlinkSpeed | SetVisible Bool -- ^ Not widely supported | SetSwapForegroundBackground Bool | SetColor ConsoleLayer ColorIntensity Color deriving (Eq, Ord, Show, Read) ansi-terminal-0.6.3.1/System/Console/ANSI/Unix.hs0000644000000000000000000000253513111265532017513 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Unix ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Codes import System.Console.ANSI.Types import System.IO (Handle, hIsTerminalDevice, hPutStr, stdout) #include "Common-Include.hs" hCursorUp h n = hPutStr h $ cursorUpCode n hCursorDown h n = hPutStr h $ cursorDownCode n hCursorForward h n = hPutStr h $ cursorForwardCode n hCursorBackward h n = hPutStr h $ cursorBackwardCode n hCursorDownLine h n = hPutStr h $ cursorDownLineCode n hCursorUpLine h n = hPutStr h $ cursorUpLineCode n hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode hClearScreen h = hPutStr h clearScreenCode hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode hClearLine h = hPutStr h clearLineCode hScrollPageUp h n = hPutStr h $ scrollPageUpCode n hScrollPageDown h n = hPutStr h $ scrollPageDownCode n hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs hHideCursor h = hPutStr h hideCursorCode hShowCursor h = hPutStr h showCursorCode hSetTitle h title = hPutStr h $ setTitleCode title ansi-terminal-0.6.3.1/System/Console/ANSI/Windows.hs0000644000000000000000000001400113111265532020211 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as U import System.Console.ANSI.Windows.Detect (isANSIEnabled) import qualified System.Console.ANSI.Windows.Emulator as E import System.IO (Handle, hIsTerminalDevice, stdout) #include "Common-Include.hs" -- * Cursor movement by character hCursorUp = if isANSIEnabled then U.hCursorUp else E.hCursorUp hCursorDown = if isANSIEnabled then U.hCursorDown else E.hCursorDown hCursorForward = if isANSIEnabled then U.hCursorForward else E.hCursorForward hCursorBackward = if isANSIEnabled then U.hCursorBackward else E.hCursorBackward cursorUpCode :: Int -> String cursorUpCode = if isANSIEnabled then U.cursorUpCode else E.cursorUpCode cursorDownCode :: Int -> String cursorDownCode = if isANSIEnabled then U.cursorDownCode else E.cursorDownCode cursorForwardCode :: Int -> String cursorForwardCode = if isANSIEnabled then U.cursorForwardCode else E.cursorForwardCode cursorBackwardCode :: Int -> String cursorBackwardCode = if isANSIEnabled then U.cursorBackwardCode else E.cursorBackwardCode -- * Cursor movement by line hCursorUpLine = if isANSIEnabled then U.hCursorUpLine else E.hCursorUpLine hCursorDownLine = if isANSIEnabled then U.hCursorDownLine else E.hCursorDownLine cursorUpLineCode :: Int -> String cursorUpLineCode = if isANSIEnabled then U.cursorUpLineCode else E.cursorUpLineCode cursorDownLineCode :: Int -> String cursorDownLineCode = if isANSIEnabled then U.cursorDownLineCode else E.cursorDownLineCode -- * Directly changing cursor position hSetCursorColumn = if isANSIEnabled then U.hSetCursorColumn else E.hSetCursorColumn setCursorColumnCode :: Int -> String setCursorColumnCode = if isANSIEnabled then U.setCursorColumnCode else E.setCursorColumnCode hSetCursorPosition = if isANSIEnabled then U.hSetCursorPosition else E.hSetCursorPosition setCursorPositionCode :: Int -> Int -> String setCursorPositionCode = if isANSIEnabled then U.setCursorPositionCode else E.setCursorPositionCode -- * Clearing parts of the screen hClearFromCursorToScreenEnd = if isANSIEnabled then U.hClearFromCursorToScreenEnd else E.hClearFromCursorToScreenEnd hClearFromCursorToScreenBeginning = if isANSIEnabled then U.hClearFromCursorToScreenBeginning else E.hClearFromCursorToScreenBeginning hClearScreen = if isANSIEnabled then U.hClearScreen else E.hClearScreen clearFromCursorToScreenEndCode :: String clearFromCursorToScreenEndCode = if isANSIEnabled then U.clearFromCursorToScreenEndCode else E.clearFromCursorToScreenEndCode clearFromCursorToScreenBeginningCode :: String clearFromCursorToScreenBeginningCode = if isANSIEnabled then U.clearFromCursorToScreenBeginningCode else E.clearFromCursorToScreenBeginningCode clearScreenCode :: String clearScreenCode = if isANSIEnabled then U.clearScreenCode else E.clearScreenCode hClearFromCursorToLineEnd = if isANSIEnabled then U.hClearFromCursorToLineEnd else E.hClearFromCursorToLineEnd hClearFromCursorToLineBeginning = if isANSIEnabled then U.hClearFromCursorToLineBeginning else E.hClearFromCursorToLineBeginning hClearLine = if isANSIEnabled then U.hClearLine else E.hClearLine clearFromCursorToLineEndCode :: String clearFromCursorToLineEndCode = if isANSIEnabled then U.clearFromCursorToLineEndCode else E.clearFromCursorToLineEndCode clearFromCursorToLineBeginningCode :: String clearFromCursorToLineBeginningCode = if isANSIEnabled then U.clearFromCursorToLineBeginningCode else E.clearFromCursorToLineBeginningCode clearLineCode :: String clearLineCode = if isANSIEnabled then U.clearLineCode else E.clearLineCode -- * Scrolling the screen hScrollPageUp = if isANSIEnabled then U.hScrollPageUp else E.hScrollPageUp hScrollPageDown = if isANSIEnabled then U.hScrollPageDown else E.hScrollPageDown scrollPageUpCode :: Int -> String scrollPageUpCode = if isANSIEnabled then U.scrollPageUpCode else E.scrollPageUpCode scrollPageDownCode :: Int -> String scrollPageDownCode = if isANSIEnabled then U.scrollPageDownCode else E.scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff -- -- The following SGR codes are NOT implemented by Windows 10 Threshold 2: -- 2 SetConsoleIntensity FaintIntensity -- 3 SetItalicized True -- 5 SetBlinkSpeed SlowBlink -- 6 SetBlinkSpeed RapidBlink -- 8 SetVisible False -- 21 SetUnderlining DoubleUnderline -- 23 SetItalicized False -- 25 SetBlinkSpeed NoBlink -- 28 SetVisible True hSetSGR = if isANSIEnabled then U.hSetSGR else E.hSetSGR setSGRCode :: [SGR] -> String setSGRCode = if isANSIEnabled then U.setSGRCode else E.setSGRCode -- * Cursor visibilty changes hHideCursor = if isANSIEnabled then U.hHideCursor else E.hHideCursor hShowCursor = if isANSIEnabled then U.hShowCursor else E.hShowCursor hideCursorCode :: String hideCursorCode = if isANSIEnabled then U.hideCursorCode else E.hideCursorCode showCursorCode :: String showCursorCode = if isANSIEnabled then U.showCursorCode else E.showCursorCode -- * Changing the title hSetTitle = if isANSIEnabled then U.hSetTitle else E.hSetTitle setTitleCode :: String -> String setTitleCode = if isANSIEnabled then U.setTitleCode else E.setTitleCode ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Detect.hs0000644000000000000000000000500413111265532021424 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows.Detect ( isANSIEnabled ) where import Control.Exception (SomeException(..), throwIO, try) import Data.Bits ((.|.)) import System.Console.ANSI.Windows.Foreign (ConsoleException(..), DWORD, eNABLE_VIRTUAL_TERMINAL_PROCESSING, getConsoleMode, getStdHandle, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, sTD_OUTPUT_HANDLE) -- 'lookupEnv' is not available until base-4.6.0.0 (GHC 7.6.1) import System.Environment.Compat (lookupEnv) import System.IO.Unsafe (unsafePerformIO) -- This function assumes that once it is first established whether or not the -- Windows console is ANSI-enabled, that will not change. {-# NOINLINE isANSIEnabled #-} isANSIEnabled :: Bool isANSIEnabled = unsafePerformIO safeIsANSIEnabled -- This function takes the following approach. If the environment variable TERM -- exists and is not set to 'dumb' or 'msys' (see below), it assumes the console -- is ANSI-enabled. Otherwise, it tries to enable virtual terminal processing. -- If that fails, it assumes the console is not ANSI-enabled. -- -- In Git Shell, if Command Prompt or PowerShell are used, the environment -- variable TERM is set to 'msys'. If 'Git Bash' (mintty) is used, TERM is set -- to 'xterm' (by default). safeIsANSIEnabled :: IO Bool safeIsANSIEnabled = do result <- lookupEnv "TERM" case result of Just "dumb" -> return False Just "msys" -> doesEnableANSIOutSucceed Just _ -> return True Nothing -> doesEnableANSIOutSucceed -- This function returns whether or not an attempt to enable virtual terminal -- processing succeeded, in the IO monad. doesEnableANSIOutSucceed :: IO Bool doesEnableANSIOutSucceed = do result <- try enableANSIOut :: IO (Either SomeException ()) case result of Left _ -> return False Right () -> return True -- This function tries to enable virtual terminal processing on the standard -- output and throws an exception if it cannot. enableANSIOut :: IO () enableANSIOut = do hOut <- getValidStdHandle sTD_OUTPUT_HANDLE mOut <- getConsoleMode hOut let mOut' = mOut .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING setConsoleMode hOut mOut' -- This function tries to get a valid standard handle and throws an exception if -- it cannot. getValidStdHandle :: DWORD -> IO HANDLE getValidStdHandle nStdHandle = do h <- getStdHandle nStdHandle if h == iNVALID_HANDLE_VALUE || h == nullHANDLE then throwIO $ ConsoleException 6 -- Invalid Handle else return h ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Emulator.hs0000644000000000000000000002670013111265532022012 0ustar0000000000000000module System.Console.ANSI.Windows.Emulator ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as Unix import System.Console.ANSI.Windows.Foreign import System.Console.ANSI.Windows.Emulator.Codes import System.IO import Control.Exception (catchJust) import Data.Bits import Data.List #include "Common-Include.hs" withHandle :: Handle -> (HANDLE -> IO a) -> IO a withHandle handle action = do -- It's VERY IMPORTANT that we flush before issuing any sort of Windows API call to change the console -- because on Windows the arrival of API-initiated state changes is not necessarily synchronised with that -- of the text they are attempting to modify. hFlush handle withHandleToHANDLE handle action -- Unfortunately, the emulator is not perfect. In particular, it has a tendency to die with exceptions about -- invalid handles when it is used with certain Windows consoles (e.g. mintty, terminator, or cygwin sshd). -- -- This happens because in those environments the stdout family of handles are not actually associated with -- a real console. -- -- My observation is that every time I've seen this in practice, the handle we have instead of the actual console -- handle is there so that the terminal supports ANSI escape codes. So 99% of the time, the correct thing to do is -- just to fall back on the Unix module to output the ANSI codes and hope for the best. emulatorFallback :: IO a -> IO a -> IO a emulatorFallback fallback first_try = catchJust invalidHandle first_try (const fallback) where invalidHandle (ConsoleException 6) = Just () -- 6 is the Windows error code for invalid handles invalidHandle (_) = Nothing adjustCursorPosition :: HANDLE -> (SHORT -> SHORT -> SHORT) -> (SHORT -> SHORT -> SHORT) -> IO () adjustCursorPosition handle change_x change_y = do screen_buffer_info <- getConsoleScreenBufferInfo handle let window = csbi_window screen_buffer_info (COORD x y) = csbi_cursor_position screen_buffer_info cursor_pos' = COORD (change_x (rect_left window) x) (change_y (rect_top window) y) setConsoleCursorPosition handle cursor_pos' hCursorUp h n = emulatorFallback (Unix.hCursorUp h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x) (\_ y -> y - fromIntegral n) hCursorDown h n = emulatorFallback (Unix.hCursorDown h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x) (\_ y -> y + fromIntegral n) hCursorForward h n = emulatorFallback (Unix.hCursorForward h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x + fromIntegral n) (\_ y -> y) hCursorBackward h n = emulatorFallback (Unix.hCursorBackward h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x - fromIntegral n) (\_ y -> y) adjustLine :: HANDLE -> (SHORT -> SHORT -> SHORT) -> IO () adjustLine handle change_y = adjustCursorPosition handle (\window_left _ -> window_left) change_y hCursorDownLine h n = emulatorFallback (Unix.hCursorDownLine h n) $ withHandle h $ \handle -> adjustLine handle (\_ y -> y + fromIntegral n) hCursorUpLine h n = emulatorFallback (Unix.hCursorUpLine h n) $ withHandle h $ \handle -> adjustLine handle (\_ y -> y - fromIntegral n) hSetCursorColumn h x = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) hSetCursorPosition h y x = emulatorFallback (Unix.hSetCursorPosition h y x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\window_top _ -> window_top + fromIntegral y) clearChar :: WCHAR clearChar = charToWCHAR ' ' clearAttribute :: WORD clearAttribute = 0 hClearScreenFraction :: HANDLE -> (SMALL_RECT -> COORD -> (DWORD, COORD)) -> IO () hClearScreenFraction handle fraction_finder = do screen_buffer_info <- getConsoleScreenBufferInfo handle let window = csbi_window screen_buffer_info cursor_pos = csbi_cursor_position screen_buffer_info (fill_length, fill_cursor_pos) = fraction_finder window cursor_pos fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos fillConsoleOutputAttribute handle clearAttribute fill_length fill_cursor_pos return () hClearFromCursorToScreenEnd h = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral fill_length, cursor_pos) where size_x = rect_width window size_y = rect_bottom window - coord_y cursor_pos line_remainder = size_x - coord_x cursor_pos fill_length = size_x * size_y + line_remainder hClearFromCursorToScreenBeginning h = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral fill_length, rect_top_left window) where size_x = rect_width window size_y = coord_y cursor_pos - rect_top window line_remainder = coord_x cursor_pos fill_length = size_x * size_y + line_remainder hClearScreen h = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window _ = (fromIntegral fill_length, rect_top_left window) where size_x = rect_width window size_y = rect_height window fill_length = size_x * size_y hClearFromCursorToLineEnd h = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral (rect_right window - coord_x cursor_pos), cursor_pos) hClearFromCursorToLineBeginning h = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral (coord_x cursor_pos), cursor_pos { coord_x = rect_left window }) hClearLine h = emulatorFallback (Unix.hClearLine h) $ withHandle h $ \handle -> hClearScreenFraction handle go where go window cursor_pos = (fromIntegral (rect_width window), cursor_pos { coord_x = rect_left window }) hScrollPage :: HANDLE -> Int -> IO () hScrollPage handle new_origin_y = do screen_buffer_info <- getConsoleScreenBufferInfo handle let fill = CHAR_INFO clearChar clearAttribute window = csbi_window screen_buffer_info origin = COORD (rect_left window) (rect_top window + fromIntegral new_origin_y) scrollConsoleScreenBuffer handle window Nothing origin fill hScrollPageUp h n = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $ \handle -> hScrollPage handle (negate n) hScrollPageDown h n = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $ \handle -> hScrollPage handle n {-# INLINE applyANSIColorToAttribute #-} applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of Black -> attribute' Red -> attribute' .|. rED Green -> attribute' .|. gREEN Yellow -> attribute' .|. rED .|. gREEN Blue -> attribute' .|. bLUE Magenta -> attribute' .|. rED .|. bLUE Cyan -> attribute' .|. gREEN .|. bLUE White -> attribute' .|. wHITE where wHITE = rED .|. gREEN .|. bLUE attribute' = attribute .&. (complement wHITE) applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute :: Color -> WORD -> WORD applyForegroundANSIColorToAttribute = applyANSIColorToAttribute fOREGROUND_RED fOREGROUND_GREEN fOREGROUND_BLUE applyBackgroundANSIColorToAttribute = applyANSIColorToAttribute bACKGROUND_RED bACKGROUND_GREEN bACKGROUND_BLUE swapForegroundBackgroundColors :: WORD -> WORD swapForegroundBackgroundColors attribute = clean_attribute .|. foreground_attribute' .|. background_attribute' where foreground_attribute = attribute .&. fOREGROUND_INTENSE_WHITE background_attribute = attribute .&. bACKGROUND_INTENSE_WHITE clean_attribute = attribute .&. complement (fOREGROUND_INTENSE_WHITE .|. bACKGROUND_INTENSE_WHITE) foreground_attribute' = background_attribute `shiftR` 4 background_attribute' = foreground_attribute `shiftL` 4 applyANSISGRToAttribute :: SGR -> WORD -> WORD applyANSISGRToAttribute sgr attribute = case sgr of Reset -> fOREGROUND_WHITE SetConsoleIntensity intensity -> case intensity of BoldIntensity -> attribute .|. iNTENSITY FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported NormalIntensity -> attribute .&. (complement iNTENSITY) SetItalicized _ -> attribute -- Not supported SetUnderlining underlining -> case underlining of NoUnderline -> attribute .&. (complement cOMMON_LVB_UNDERSCORE) _ -> attribute .|. cOMMON_LVB_UNDERSCORE -- Not supported, since cOMMON_LVB_UNDERSCORE seems to have no effect SetBlinkSpeed _ -> attribute -- Not supported SetVisible _ -> attribute -- Not supported -- The cOMMON_LVB_REVERSE_VIDEO doesn't actually appear to have any affect on the colors being displayed, so the emulator -- just uses it to carry information and implements the color-swapping behaviour itself. Bit of a hack, I guess :-) SetSwapForegroundBackground True -> -- Check if the color-swapping flag is already set if attribute .&. cOMMON_LVB_REVERSE_VIDEO /= 0 then attribute else swapForegroundBackgroundColors attribute .|. cOMMON_LVB_REVERSE_VIDEO SetSwapForegroundBackground False -> -- Check if the color-swapping flag is already not set if attribute .&. cOMMON_LVB_REVERSE_VIDEO == 0 then attribute else swapForegroundBackgroundColors attribute .&. (complement cOMMON_LVB_REVERSE_VIDEO) SetColor Foreground Dull color -> applyForegroundANSIColorToAttribute color (attribute .&. (complement fOREGROUND_INTENSITY)) SetColor Foreground Vivid color -> applyForegroundANSIColorToAttribute color (attribute .|. fOREGROUND_INTENSITY) SetColor Background Dull color -> applyBackgroundANSIColorToAttribute color (attribute .&. (complement bACKGROUND_INTENSITY)) SetColor Background Vivid color -> applyBackgroundANSIColorToAttribute color (attribute .|. bACKGROUND_INTENSITY) where iNTENSITY = fOREGROUND_INTENSITY hSetSGR h sgr = emulatorFallback (Unix.hSetSGR h sgr) $ withHandle h $ \handle -> do screen_buffer_info <- getConsoleScreenBufferInfo handle let attribute = csbi_attributes screen_buffer_info attribute' = foldl' (flip applyANSISGRToAttribute) attribute -- make [] equivalent to [Reset], as documented (if null sgr then [Reset] else sgr) setConsoleTextAttribute handle attribute' hChangeCursorVisibility :: HANDLE -> Bool -> IO () hChangeCursorVisibility handle cursor_visible = do cursor_info <- getConsoleCursorInfo handle setConsoleCursorInfo handle (cursor_info { cci_cursor_visible = cursor_visible }) hHideCursor h = emulatorFallback (Unix.hHideCursor h) $ withHandle h $ \handle -> hChangeCursorVisibility handle False hShowCursor h = emulatorFallback (Unix.hShowCursor h) $ withHandle h $ \handle -> hChangeCursorVisibility handle True -- Windows only supports setting the terminal title on a process-wide basis, so for now we will -- assume that that is what the user intended. This will fail if they are sending the command -- over e.g. a network link... but that's not really what I'm designing for. hSetTitle h title = emulatorFallback (Unix.hSetTitle h title) $ withTString title $ setConsoleTitle ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Emulator/Codes.hs0000644000000000000000000000536213111265532023050 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows.Emulator.Codes ( -- * Cursor movement by character cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode -- * Cursor movement by line , cursorUpLineCode, cursorDownLineCode -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode , clearFromCursorToLineBeginningCode, clearLineCode -- * Scrolling the screen , scrollPageUpCode, scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff , setSGRCode -- * Cursor visibilty changes , hideCursorCode, showCursorCode -- * Changing the title , setTitleCode ) where import System.Console.ANSI.Types cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: Int -- ^ Number of lines or characters to move -> String cursorUpCode _ = "" cursorDownCode _ = "" cursorForwardCode _ = "" cursorBackwardCode _ = "" cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move -> String cursorDownLineCode _ = "" cursorUpLineCode _ = "" setCursorColumnCode :: Int -- ^ 0-based column to move to -> String setCursorColumnCode _ = "" setCursorPositionCode :: Int -- ^ 0-based row to move to -> Int -- ^ 0-based column to move to -> String setCursorPositionCode _ _ = "" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String clearFromCursorToScreenEndCode = "" clearFromCursorToScreenBeginningCode = "" clearScreenCode = "" clearFromCursorToLineEndCode = "" clearFromCursorToLineBeginningCode = "" clearLineCode = "" scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by -> String scrollPageUpCode _ = "" scrollPageDownCode _ = "" setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the -- current console SGR mode. An empty list of commands is -- equivalent to the list @[Reset]@. Commands are applied -- left to right. -> String setSGRCode _ = "" hideCursorCode, showCursorCode :: String hideCursorCode = "" showCursorCode = "" setTitleCode :: String -- ^ New title -> String setTitleCode _ = "" ansi-terminal-0.6.3.1/System/Console/ANSI/Windows/Foreign.hs0000644000000000000000000003624513112042701021610 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} -- | "System.Win32.Console" is really very impoverished, so I have had to do all the FFI myself. module System.Console.ANSI.Windows.Foreign ( -- Re-exports from Win32.Types BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, charToWCHAR, COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, rect_width, rect_height, CONSOLE_CURSOR_INFO(..), CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING, fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE, cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE, getStdHandle, getConsoleScreenBufferInfo, getConsoleCursorInfo, getConsoleMode, setConsoleTextAttribute, setConsoleCursorPosition, setConsoleCursorInfo, setConsoleTitle, setConsoleMode, fillConsoleOutputAttribute, fillConsoleOutputCharacter, scrollConsoleScreenBuffer, withTString, withHandleToHANDLE, -- ConsoleException(..) ) where import Foreign.C.Types import Foreign.Marshal import Foreign.Ptr import Foreign.Storable import Data.Bits import Data.Char import System.Win32.Types import Control.Exception (Exception, throw) #if __GLASGOW_HASKELL__ >= 612 import Data.Typeable #endif #if !MIN_VERSION_Win32(2,5,1) import Control.Concurrent.MVar import Foreign.StablePtr import Control.Exception (bracket) #if __GLASGOW_HASKELL__ >= 612 import GHC.IO.Handle.Types (Handle(..), Handle__(..)) import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 import Data.Typeable #else import GHC.IOBase (Handle(..), Handle__(..)) import qualified GHC.IOBase as IOBase (FD) -- Just an Int32 #endif #endif #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall #elif defined(x86_64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch #endif --import System.Console.ANSI.Windows.Foreign.Compat #if !MIN_VERSION_Win32(2,5,0) -- Some Windows types missing from System.Win32 prior version 2.5.0.0 type SHORT = CShort #endif type WCHAR = CWchar charToWCHAR :: Char -> WCHAR charToWCHAR char = fromIntegral (ord char) -- This is a FFI hack. Some of the API calls take a Coord, but that isn't a built-in FFI type so I can't -- use it directly. Instead, I use UNPACKED_COORD and marshal COORDs into this manually. Note that we CAN'T -- just use two SHORTs directly because they get expanded to 4 bytes each instead of just boing 2 lots of 2 -- bytes by the stdcall convention, so linking fails. type UNPACKED_COORD = CInt -- Field packing order determined experimentally: I couldn't immediately find a specification for Windows -- struct layout anywhere. unpackCOORD :: COORD -> UNPACKED_COORD unpackCOORD (COORD x y) = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x) peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) peekAndOffset ptr = do item <- peek ptr return (item, ptr `plusPtr` sizeOf item) pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) pokeAndOffset ptr item = do poke ptr item return (ptr `plusPtr` sizeOf item) data COORD = COORD { coord_x :: SHORT, coord_y :: SHORT } instance Show COORD where show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" instance Storable COORD where sizeOf ~(COORD x y) = sizeOf x + sizeOf y alignment ~(COORD x _) = alignment x peek ptr = do let ptr' = castPtr ptr :: Ptr SHORT x <- peekElemOff ptr' 0 y <- peekElemOff ptr' 1 return (COORD x y) poke ptr (COORD x y) = do let ptr' = castPtr ptr :: Ptr SHORT pokeElemOff ptr' 0 x pokeElemOff ptr' 1 y data SMALL_RECT = SMALL_RECT { rect_top_left :: COORD, rect_bottom_right :: COORD } rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT rect_top = coord_y . rect_top_left rect_left = coord_x . rect_top_left rect_bottom = coord_y . rect_bottom_right rect_right = coord_x . rect_bottom_right rect_width, rect_height :: SMALL_RECT -> SHORT rect_width rect = rect_right rect - rect_left rect + 1 rect_height rect = rect_bottom rect - rect_top rect + 1 instance Show SMALL_RECT where show (SMALL_RECT tl br) = show tl ++ "-" ++ show br instance Storable SMALL_RECT where sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br alignment ~(SMALL_RECT tl _) = alignment tl peek ptr = do let ptr' = castPtr ptr :: Ptr COORD tl <- peekElemOff ptr' 0 br <- peekElemOff ptr' 1 return (SMALL_RECT tl br) poke ptr (SMALL_RECT tl br) = do let ptr' = castPtr ptr :: Ptr COORD pokeElemOff ptr' 0 tl pokeElemOff ptr' 1 br data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO { cci_cursor_size :: DWORD, cci_cursor_visible :: BOOL } deriving (Show) instance Storable CONSOLE_CURSOR_INFO where sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size peek ptr = do (size, ptr') <- peekAndOffset (castPtr ptr) visible <- peek ptr' return (CONSOLE_CURSOR_INFO size visible) poke ptr (CONSOLE_CURSOR_INFO size visible) = do ptr' <- pokeAndOffset (castPtr ptr) size poke ptr' visible data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO { csbi_size :: COORD, csbi_cursor_position :: COORD, csbi_attributes :: WORD, csbi_window :: SMALL_RECT, csbi_maximum_window_size :: COORD } deriving (Show) instance Storable CONSOLE_SCREEN_BUFFER_INFO where sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + sizeOf maximum_window_size alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size peek ptr = do (size, ptr1) <- peekAndOffset (castPtr ptr) (cursor_position, ptr2) <- peekAndOffset ptr1 (attributes, ptr3) <- peekAndOffset ptr2 (window, ptr4) <- peekAndOffset ptr3 maximum_window_size <- peek ptr4 return (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do ptr1 <- pokeAndOffset (castPtr ptr) size ptr2 <- pokeAndOffset ptr1 cursor_position ptr3 <- pokeAndOffset ptr2 attributes ptr4 <- pokeAndOffset ptr3 window poke ptr4 maximum_window_size data CHAR_INFO = CHAR_INFO { ci_char :: WCHAR, ci_attributes :: WORD } deriving (Show) instance Storable CHAR_INFO where sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes alignment ~(CHAR_INFO char _) = alignment char peek ptr = do (char, ptr') <- peekAndOffset (castPtr ptr) attributes <- peek ptr' return (CHAR_INFO char attributes) poke ptr (CHAR_INFO char attributes) = do ptr' <- pokeAndOffset (castPtr ptr) char poke ptr' attributes eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD eNABLE_VIRTUAL_TERMINAL_INPUT = 512 eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 sTD_INPUT_HANDLE = -10 sTD_OUTPUT_HANDLE = -11 sTD_ERROR_HANDLE = -12 fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD fOREGROUND_BLUE = 0x1 fOREGROUND_GREEN = 0x2 fOREGROUND_RED = 0x4 fOREGROUND_INTENSITY = 0x8 bACKGROUND_BLUE = 0x10 bACKGROUND_GREEN = 0x20 bACKGROUND_RED= 0x40 bACKGROUND_INTENSITY = 0x80 cOMMON_LVB_REVERSE_VIDEO = 0x4000 cOMMON_LVB_UNDERSCORE = 0x8000 fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_INTENSE_WHITE :: WORD fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle" getStdHandle :: DWORD -> IO HANDLE foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute" cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo" cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute" cFillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW" cFillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW" cScrollConsoleScreenBuffer :: HANDLE -> Ptr SMALL_RECT -> Ptr SMALL_RECT -> UNPACKED_COORD -> Ptr CHAR_INFO -> IO BOOL data ConsoleException = ConsoleException !ErrCode deriving (Show, Eq, Typeable) instance Exception ConsoleException throwIfFalse :: IO Bool -> IO () throwIfFalse action = do succeeded <- action if not succeeded then getLastError >>= throw . ConsoleException -- TODO: Check if last error is zero for some instructable reason (?) else return () getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do throwIfFalse $ cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info peek ptr_console_screen_buffer_info getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info peek ptr_console_cursor_info getConsoleMode :: HANDLE -> IO DWORD getConsoleMode handle = alloca $ \ptr_mode -> do throwIfFalse $ cGetConsoleMode handle ptr_mode peek ptr_mode setConsoleTextAttribute :: HANDLE -> WORD -> IO () setConsoleTextAttribute handle attributes = throwIfFalse $ cSetConsoleTextAttribute handle attributes setConsoleCursorPosition :: HANDLE -> COORD -> IO () setConsoleCursorPosition handle cursor_position = throwIfFalse $ cSetConsoleCursorPosition handle (unpackCOORD cursor_position) setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO () setConsoleCursorInfo handle console_cursor_info = with console_cursor_info $ \ptr_console_cursor_info -> do throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info setConsoleTitle :: LPCTSTR -> IO () setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title setConsoleMode :: HANDLE -> DWORD -> IO () setConsoleMode handle attributes = throwIfFalse $ cSetConsoleMode handle attributes fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD fillConsoleOutputAttribute handle attribute fill_length write_origin = alloca $ \ptr_chars_written -> do throwIfFalse $ cFillConsoleOutputAttribute handle attribute fill_length (unpackCOORD write_origin) ptr_chars_written peek ptr_chars_written fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD fillConsoleOutputCharacter handle char fill_length write_origin = alloca $ \ptr_chars_written -> do throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length (unpackCOORD write_origin) ptr_chars_written peek ptr_chars_written scrollConsoleScreenBuffer :: HANDLE -> SMALL_RECT -> Maybe SMALL_RECT -> COORD -> CHAR_INFO -> IO () scrollConsoleScreenBuffer handle scroll_rectangle mb_clip_rectangle destination_origin fill = with scroll_rectangle $ \ptr_scroll_rectangle -> maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle -> with fill $ \ptr_fill -> throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill #if !MIN_VERSION_Win32(2,5,1) -- | This bit is all highly dubious. The problem is that we want to output ANSI to arbitrary Handles rather than forcing -- people to use stdout. However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able -- to extract one of those from the Haskell Handle. -- -- This code accomplishes this, albeit at the cost of only being compatible with GHC. -- withHandleToHANDLE was added in Win32-2.5.1.0 withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a withHandleToHANDLE haskell_handle action = -- Create a stable pointer to the Handle. This prevents the garbage collector -- getting to it while we are doing horrible manipulations with it, and hence -- stops it being finalized (and closed). withStablePtr haskell_handle $ const $ do -- Grab the write handle variable from the Handle let write_handle_mvar = case haskell_handle of FileHandle _ handle_mvar -> handle_mvar DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one -- Get the FD from the algebraic data type #if __GLASGOW_HASKELL__ < 612 fd <- fmap haFD $ readMVar write_handle_mvar #else --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev) Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar #endif -- Finally, turn that (C-land) FD into a HANDLE using msvcrt windows_handle <- cget_osfhandle fd -- Do what the user originally wanted action windows_handle -- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah! #if __GLASGOW_HASKELL__ >= 612 foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE #else foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE #endif -- withStablePtr was added in Win32-2.5.1.0 withStablePtr :: a -> (StablePtr a -> IO b) -> IO b withStablePtr value = bracket (newStablePtr value) freeStablePtr #endif ansi-terminal-0.6.3.1/LICENSE0000644000000000000000000000276612253056123013627 0ustar0000000000000000Copyright (c) 2008, Maximilian Bolingbroke All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.ansi-terminal-0.6.3.1/Setup.lhs0000644000000000000000000000011512253056123014414 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMainansi-terminal-0.6.3.1/ansi-terminal.cabal0000644000000000000000000000734313113550571016347 0ustar0000000000000000Name: ansi-terminal Version: 0.6.3.1 Cabal-Version: >= 1.6 Category: User Interfaces Synopsis: Simple ANSI terminal support, with Windows compatibility Description: ANSI terminal support for Haskell: allows cursor movement, screen clearing, color output showing or hiding the cursor, and changing the title. Compatible with Windows and those Unixes with ANSI terminals, but only GHC is supported as a compiler. License: BSD3 License-File: LICENSE Author: Max Bolingbroke Maintainer: Roman Cheplyaka Homepage: https://github.com/feuerbach/ansi-terminal Build-Type: Simple Extra-Source-Files: includes/Common-Include.hs includes/Exports-Include.hs CHANGELOG.md README.md Source-repository head type: git location: git://github.com/feuerbach/ansi-terminal.git Flag Example Description: Build the example application Default: False Library Exposed-Modules: System.Console.ANSI System.Console.ANSI.Types System.Console.ANSI.Codes Include-Dirs: includes Build-Depends: base >= 4 && < 5 if os(windows) Build-Depends: base-compat >= 0.9.1 , Win32 >= 2.0 , process Cpp-Options: -DWINDOWS Other-Modules: System.Console.ANSI.Windows System.Console.ANSI.Windows.Detect System.Console.ANSI.Windows.Emulator System.Console.ANSI.Windows.Emulator.Codes System.Console.ANSI.Windows.Foreign -- NB: used for fallback by the emulator System.Console.ANSI.Unix else -- We assume any non-Windows platform is Unix Cpp-Options: -DUNIX Other-Modules: System.Console.ANSI.Unix Extensions: CPP ForeignFunctionInterface Ghc-Options: -Wall Executable ansi-terminal-example Main-Is: System/Console/ANSI/Example.hs Include-Dirs: includes Other-Modules: System.Console.ANSI System.Console.ANSI.Codes System.Console.ANSI.Types System.Console.ANSI.Unix if os(windows) Build-Depends: base-compat >= 0.9.1 , Win32 >= 2.0 Cpp-Options: -DWINDOWS Other-Modules: System.Console.ANSI.Windows System.Console.ANSI.Windows.Detect System.Console.ANSI.Windows.Emulator System.Console.ANSI.Windows.Emulator.Codes System.Console.ANSI.Windows.Foreign else -- We assume any non-Windows platform is Unix Cpp-Options: -DUNIX Build-Depends: base >= 4 && < 5 Extensions: CPP ForeignFunctionInterface Ghc-Options: -Wall if !flag(example) Buildable: False ansi-terminal-0.6.3.1/includes/Common-Include.hs0000644000000000000000000001115413111265532017564 0ustar0000000000000000import System.Environment #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif hCursorUp, hCursorDown, hCursorForward, hCursorBackward :: Handle -> Int -- ^ Number of lines or characters to move -> IO () cursorUp, cursorDown, cursorForward, cursorBackward :: Int -- ^ Number of lines or characters to move -> IO () cursorUp = hCursorUp stdout cursorDown = hCursorDown stdout cursorForward = hCursorForward stdout cursorBackward = hCursorBackward stdout hCursorDownLine, hCursorUpLine :: Handle -> Int -- ^ Number of lines to move -> IO () cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move -> IO () cursorDownLine = hCursorDownLine stdout cursorUpLine = hCursorUpLine stdout hSetCursorColumn :: Handle -> Int -- ^ 0-based column to move to -> IO () setCursorColumn :: Int -- ^ 0-based column to move to -> IO () setCursorColumn = hSetCursorColumn stdout hSetCursorPosition :: Handle -> Int -- ^ 0-based row to move to -> Int -- ^ 0-based column to move to -> IO () setCursorPosition :: Int -- ^ 0-based row to move to -> Int -- ^ 0-based column to move to -> IO () setCursorPosition = hSetCursorPosition stdout hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen :: Handle -> IO () clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: IO () clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout clearScreen = hClearScreen stdout hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine :: Handle -> IO () clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: IO () clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout clearLine = hClearLine stdout -- | Scroll the displayed information up or down the terminal: not widely supported hScrollPageUp, hScrollPageDown :: Handle -> Int -- ^ Number of lines to scroll by -> IO () -- | Scroll the displayed information up or down the terminal: not widely supported scrollPageUp, scrollPageDown :: Int -- ^ Number of lines to scroll by -> IO () -- | Scroll the displayed information up or down the terminal: not widely supported scrollPageUp = hScrollPageUp stdout scrollPageDown = hScrollPageDown stdout -- | Set the Select Graphic Rendition mode hSetSGR :: Handle -> [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied -- left to right. -> IO () -- | Set the Select Graphic Rendition mode setSGR :: [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied -- left to right. -> IO () -- | Set the Select Graphic Rendition mode setSGR = hSetSGR stdout hHideCursor, hShowCursor :: Handle -> IO () hideCursor, showCursor :: IO () hideCursor = hHideCursor stdout showCursor = hShowCursor stdout -- | Set the terminal window title hSetTitle :: Handle -> String -- ^ New title -> IO () -- | Set the terminal window title setTitle :: String -- ^ New title -> IO () setTitle = hSetTitle stdout -- | Use heuristics to determine whether the functions defined in this -- package will work with a given handle. -- -- The current implementation checks that the handle is a terminal, and -- that the @TERM@ environment variable doesn't say @dumb@ (which is what -- Emacs sets for its own terminal). hSupportsANSI :: Handle -> IO Bool -- Borrowed from an HSpec patch by Simon Hengel -- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) hSupportsANSI h = (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb) where -- cannot use lookupEnv since it only appeared in GHC 7.6 isDumb = maybe False (== "dumb") . lookup "TERM" <$> getEnvironment ansi-terminal-0.6.3.1/includes/Exports-Include.hs0000644000000000000000000000370013111265532017776 0ustar0000000000000000-- * Basic data types module System.Console.ANSI.Types, -- * Cursor movement by character cursorUp, cursorDown, cursorForward, cursorBackward, hCursorUp, hCursorDown, hCursorForward, hCursorBackward, cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode, -- * Cursor movement by line -- | The difference between movements \"by character\" and \"by line\" is -- that @*Line@ functions additionally move the cursor to the start of the -- line, while functions like @cursorUp@ and @cursorDown@ keep the column -- the same. -- -- Also keep in mind that @*Line@ functions are not as portable. See -- for the details. cursorUpLine, cursorDownLine, hCursorUpLine, hCursorDownLine, cursorUpLineCode, cursorDownLineCode, -- * Directly changing cursor position setCursorColumn, hSetCursorColumn, setCursorColumnCode, setCursorPosition, hSetCursorPosition, setCursorPositionCode, -- * Clearing parts of the screen -- | Note that these functions only clear parts of the screen. They do not move the -- cursor. clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen, hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen, clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode, clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine, hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine, clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode, -- * Scrolling the screen scrollPageUp, scrollPageDown, hScrollPageUp, hScrollPageDown, scrollPageUpCode, scrollPageDownCode, -- * Select Graphic Rendition mode: colors and other whizzy stuff setSGR, hSetSGR, setSGRCode, -- * Cursor visibilty changes hideCursor, showCursor, hHideCursor, hShowCursor, hideCursorCode, showCursorCode, -- * Changing the title setTitle, hSetTitle, setTitleCode, -- * Checking if handle supports ANSI hSupportsANSI ansi-terminal-0.6.3.1/CHANGELOG.md0000644000000000000000000000142413113550562014423 0ustar0000000000000000Changes ======= Version 0.6.3.1 --------------- Fix Windows + ghc 7.8 compatibility, Version 0.6.3 ------------- * Add ANSI support for Windows * Add compatibility with Win32-2.5.0.0 and above Version 0.6.2.3 --------------- Add an example to the haddocks Version 0.6.2.2 --------------- Fix a GHC 7.10 warning Version 0.6.2.1 --------------- Restore compatibility with GHC 7.4 and older Version 0.6.2 ------------- * Add `hSupportsANSI` * Drop support for `base < 4` Version 0.6.1.1 --------------- Fix to build with GHC 7.8 on Windows Version 0.6.1 ------------- * `BoldIntensity` no longer changes background color on Windows * `setSGR []` was not equivalent to `setSGR [Reset]` on Windows, even though it should be according to the documentation. This is now fixed. ansi-terminal-0.6.3.1/README.md0000644000000000000000000000544112332717672014105 0ustar0000000000000000ansi-terminal ============= Haskell ANSI Terminal Package For Windows, OS X and Linux Description ----------- [ANSI](http://en.wikipedia.org/wiki/ANSI_escape_sequences) terminal support for Haskell, which allows: - Cursor movement - Screen and line clearing - Color output - Showing or hiding the cursor - Changing the console title (though this is not strictly part of ANSI, it is widely supported in Unix) It is compatible with Windows (via an emulation layer) and those Unixes with ANSI terminals. If you like this, you may be interested in [ansi-wl-pprint](http://github.com/batterseapower/ansi-wl-pprint), which provides a pretty-printer that can construct strings containing ANSI colorisation. Not all of the ANSI escape codes are provided by this module, but most (if not all) of the popular and well supported ones are. For a full list, have a look at the [current version of the API](http://github.com/feuerbach/ansi-terminal/tree/master/includes/Common-Include.hs). Each supported escape code or family of codes has a corresponding function that comes in three variants: - A straight `IO` variant that doesn't take a `Handle` and just applies the ANSI escape code to the terminal attached to stdout - An `IO` variant similar to above, but which takes a `Handle` to which the ANSI escape should be applied - A `String` variant that returns a literal string that should be included to get the effect of the code. This is the only one of the three API variants that only works on Unix-like operating systems: on Windows these strings will always be blank! Example ------- A full example is [available](http://github.com/feuerbach/ansi-terminal/tree/master/System/Console/ANSI/Example.hs), but for a taste of how the library works try the following code: ``` haskell import System.Console.ANSI main = do setCursorPosition 5 0 setTitle "ANSI Terminal Short Example" setSGR [ SetConsoleIntensity BoldIntensity , SetColor Foreground Vivid Red ] putStr "Hello" setSGR [ SetConsoleIntensity NormalIntensity , SetColor Foreground Vivid White , SetColor Background Dull Blue ] putStrLn "World!" ``` ![](https://raw.githubusercontent.com/feuerbach/ansi-terminal/master/example.png) Documentation ------------- Haddock documentation is [available at Hackage](http://hackage.haskell.org/packages/archive/ansi-terminal/latest/doc/html/System-Console-ANSI.html). Credits ------- The library is originally written by [Max Bolingbroke](https://github.com/batterseapower) Maintainers ----------- [Roman Cheplyaka](https://github.com/feuerbach) is the primary maintainer. [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please get in touch with him if the primary maintainer cannot be reached.