ansi-terminal-0.6.2.3/System/0000755000000000000000000000000012253056123014074 5ustar0000000000000000ansi-terminal-0.6.2.3/System/Console/0000755000000000000000000000000012574225714015510 5ustar0000000000000000ansi-terminal-0.6.2.3/System/Console/ANSI/0000755000000000000000000000000012574225522016237 5ustar0000000000000000ansi-terminal-0.6.2.3/System/Console/ANSI/Windows/0000755000000000000000000000000012565355112017670 5ustar0000000000000000ansi-terminal-0.6.2.3/includes/0000755000000000000000000000000012565355112014424 5ustar0000000000000000ansi-terminal-0.6.2.3/System/Console/ANSI.hs0000644000000000000000000000473712574225714016611 0ustar0000000000000000-- | Provides ANSI terminal support for Windows and ANSI terminal software running on a Unix-like operating system. -- -- 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 your 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 due to fundamental limitations in -- Windows ANSI terminal support will only work on Unix. On Windows 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 a Unix-like operating system. -- -- 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 #endifansi-terminal-0.6.2.3/System/Console/ANSI/Common.hs0000644000000000000000000000406012253056123020014 0ustar0000000000000000module System.Console.ANSI.Common 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.2.3/System/Console/ANSI/Windows.hs0000644000000000000000000000027312253056123020220 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Common import System.Console.ANSI.Windows.Emulator ansi-terminal-0.6.2.3/System/Console/ANSI/Windows/Foreign.hs0000644000000000000000000003314512274364000021614 0ustar0000000000000000-- | "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, 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, 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, setConsoleTextAttribute, setConsoleCursorPosition, setConsoleCursorInfo, setConsoleTitle, fillConsoleOutputAttribute, fillConsoleOutputCharacter, scrollConsoleScreenBuffer, withTString, withHandleToHANDLE ) 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.Concurrent.MVar import Control.Exception (bracket) import Foreign.StablePtr #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 -- Some Windows types missing from System.Win32 type SHORT = CShort 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 sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD 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 stdcall unsafe "windows.h GetStdHandle" getStdHandle :: DWORD -> IO HANDLE foreign import stdcall unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL foreign import stdcall unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleTextAttribute" cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleCursorInfo" cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL foreign import stdcall unsafe "windows.h FillConsoleOutputAttribute" cFillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import stdcall unsafe "windows.h FillConsoleOutputCharacterW" cFillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import stdcall unsafe "windows.h ScrollConsoleScreenBufferW" cScrollConsoleScreenBuffer :: HANDLE -> Ptr SMALL_RECT -> Ptr SMALL_RECT -> UNPACKED_COORD -> Ptr CHAR_INFO -> IO BOOL getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do failIfFalse_ "getConsoleScreenBufferInfo" $ 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 failIfFalse_ "getConsoleCursorInfo" $ cGetConsoleCursorInfo handle ptr_console_cursor_info peek ptr_console_cursor_info setConsoleTextAttribute :: HANDLE -> WORD -> IO () setConsoleTextAttribute handle attributes = failIfFalse_ "setConsoleTextAttribute" $ cSetConsoleTextAttribute handle attributes setConsoleCursorPosition :: HANDLE -> COORD -> IO () setConsoleCursorPosition handle cursor_position = failIfFalse_ "setConsoleCursorPosition" $ 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 failIfFalse_ "setConsoleCursorInfo" $ cSetConsoleCursorInfo handle ptr_console_cursor_info setConsoleTitle :: LPCTSTR -> IO () setConsoleTitle title = failIfFalse_ "setConsoleTitle" $ cSetConsoleTitle title fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD fillConsoleOutputAttribute handle attribute fill_length write_origin = alloca $ \ptr_chars_written -> do failIfFalse_ "fillConsoleOutputAttribute" $ 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 failIfFalse_ "fillConsoleOutputCharacter" $ 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 -> failIfFalse_ "scrollConsoleScreenBuffer" $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill -- 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 ccall unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE #else foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE #endif -- | 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 :: 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 withStablePtr :: a -> (StablePtr a -> IO b) -> IO b withStablePtr value = bracket (newStablePtr value) freeStablePtransi-terminal-0.6.2.3/System/Console/ANSI/Windows/Emulator.hs0000644000000000000000000003066112565355112022022 0ustar0000000000000000module System.Console.ANSI.Windows.Emulator ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Common import qualified System.Console.ANSI.Unix as Unix import System.Console.ANSI.Windows.Foreign import System.IO import Control.Exception (SomeException, catchJust) import Control.Monad (guard) import Data.Bits import Data.Char (toLower) 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 (\e -> guard (isHandleIsInvalidException e) >> return ()) first_try (\() -> fallback) where -- NB: this is a pretty hacked-up way to find out if we have the right sort of exception, but System.Win32.Types.fail* call into -- the fail :: String -> IO a function, and so we don't get any nice exception object we can extract information from. isHandleIsInvalidException :: SomeException -> Bool isHandleIsInvalidException e = "the handle is invalid" `isInfixOf` e_string || "invalid handle" `isInfixOf` e_string where e_string = map toLower (show e) 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) cursorUpCode _ = "" cursorDownCode _ = "" cursorForwardCode _ = "" cursorBackwardCode _ = "" 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) cursorDownLineCode _ = "" cursorUpLineCode _ = "" hSetCursorColumn h x = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) setCursorColumnCode _ = "" 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) setCursorPositionCode _ _ = "" 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 }) clearFromCursorToScreenEndCode = "" clearFromCursorToScreenBeginningCode = "" clearScreenCode = "" clearFromCursorToLineEndCode = "" clearFromCursorToLineBeginningCode = "" clearLineCode = "" 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 scrollPageUpCode _ = "" scrollPageDownCode _ = "" {-# 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' setSGRCode _ = "" 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 hideCursorCode = "" showCursorCode = "" -- 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 setTitleCode _ = "" ansi-terminal-0.6.2.3/System/Console/ANSI/Unix.hs0000644000000000000000000000742512422731647017530 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Unix ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Common import System.IO import Data.List #include "Common-Include.hs" -- | The reference I used for the ANSI escape characters in this module was . csi :: [Int] -> String -> String csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code 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 -> 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 n = csi [n] "A" cursorDownCode n = csi [n] "B" cursorForwardCode n = csi [n] "C" cursorBackwardCode n = csi [n] "D" 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 cursorDownLineCode n = csi [n] "E" cursorUpLineCode n = csi [n] "F" hCursorDownLine h n = hPutStr h $ cursorDownLineCode n hCursorUpLine h n = hPutStr h $ cursorUpLineCode n setCursorColumnCode n = csi [n + 1] "G" setCursorPositionCode n m = csi [n + 1, m + 1] "H" hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m clearFromCursorToScreenEndCode = csi [0] "J" clearFromCursorToScreenBeginningCode = csi [1] "J" clearScreenCode = csi [2] "J" hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode hClearScreen h = hPutStr h clearScreenCode clearFromCursorToLineEndCode = csi [0] "K" clearFromCursorToLineBeginningCode = csi [1] "K" clearLineCode = csi [2] "K" hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode hClearLine h = hPutStr h clearLineCode scrollPageUpCode n = csi [n] "S" scrollPageDownCode n = csi [n] "T" hScrollPageUp h n = hPutStr h $ scrollPageUpCode n hScrollPageDown h n = hPutStr h $ scrollPageDownCode n setSGRCode sgrs = csi (map sgrToCode sgrs) "m" hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs hideCursorCode = csi [] "?25l" showCursorCode = csi [] "?25h" hHideCursor h = hPutStr h hideCursorCode hShowCursor h = hPutStr h showCursorCode -- | 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 title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007" hSetTitle h title = hPutStr h $ setTitleCode titleansi-terminal-0.6.2.3/System/Console/ANSI/Example.hs0000644000000000000000000001307412253056123020164 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 resetScreen :: IO () resetScreen = clearScreen >> setSGR [Reset] >> 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 Demoansi-terminal-0.6.2.3/System/Console/ANSI/Windows.hs0000644000000000000000000000027312253056123020220 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Windows ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Common import System.Console.ANSI.Windows.Emulator ansi-terminal-0.6.2.3/System/Console/ANSI/Windows/Foreign.hs0000644000000000000000000003314512274364000021614 0ustar0000000000000000-- | "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, 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, 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, setConsoleTextAttribute, setConsoleCursorPosition, setConsoleCursorInfo, setConsoleTitle, fillConsoleOutputAttribute, fillConsoleOutputCharacter, scrollConsoleScreenBuffer, withTString, withHandleToHANDLE ) 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.Concurrent.MVar import Control.Exception (bracket) import Foreign.StablePtr #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 -- Some Windows types missing from System.Win32 type SHORT = CShort 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 sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD 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 stdcall unsafe "windows.h GetStdHandle" getStdHandle :: DWORD -> IO HANDLE foreign import stdcall unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL foreign import stdcall unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleTextAttribute" cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleCursorInfo" cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import stdcall unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL foreign import stdcall unsafe "windows.h FillConsoleOutputAttribute" cFillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import stdcall unsafe "windows.h FillConsoleOutputCharacterW" cFillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import stdcall unsafe "windows.h ScrollConsoleScreenBufferW" cScrollConsoleScreenBuffer :: HANDLE -> Ptr SMALL_RECT -> Ptr SMALL_RECT -> UNPACKED_COORD -> Ptr CHAR_INFO -> IO BOOL getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do failIfFalse_ "getConsoleScreenBufferInfo" $ 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 failIfFalse_ "getConsoleCursorInfo" $ cGetConsoleCursorInfo handle ptr_console_cursor_info peek ptr_console_cursor_info setConsoleTextAttribute :: HANDLE -> WORD -> IO () setConsoleTextAttribute handle attributes = failIfFalse_ "setConsoleTextAttribute" $ cSetConsoleTextAttribute handle attributes setConsoleCursorPosition :: HANDLE -> COORD -> IO () setConsoleCursorPosition handle cursor_position = failIfFalse_ "setConsoleCursorPosition" $ 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 failIfFalse_ "setConsoleCursorInfo" $ cSetConsoleCursorInfo handle ptr_console_cursor_info setConsoleTitle :: LPCTSTR -> IO () setConsoleTitle title = failIfFalse_ "setConsoleTitle" $ cSetConsoleTitle title fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD fillConsoleOutputAttribute handle attribute fill_length write_origin = alloca $ \ptr_chars_written -> do failIfFalse_ "fillConsoleOutputAttribute" $ 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 failIfFalse_ "fillConsoleOutputCharacter" $ 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 -> failIfFalse_ "scrollConsoleScreenBuffer" $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill -- 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 ccall unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE #else foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE #endif -- | 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 :: 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 withStablePtr :: a -> (StablePtr a -> IO b) -> IO b withStablePtr value = bracket (newStablePtr value) freeStablePtransi-terminal-0.6.2.3/System/Console/ANSI/Windows/Emulator.hs0000644000000000000000000003066112565355112022022 0ustar0000000000000000module System.Console.ANSI.Windows.Emulator ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Common import qualified System.Console.ANSI.Unix as Unix import System.Console.ANSI.Windows.Foreign import System.IO import Control.Exception (SomeException, catchJust) import Control.Monad (guard) import Data.Bits import Data.Char (toLower) 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 (\e -> guard (isHandleIsInvalidException e) >> return ()) first_try (\() -> fallback) where -- NB: this is a pretty hacked-up way to find out if we have the right sort of exception, but System.Win32.Types.fail* call into -- the fail :: String -> IO a function, and so we don't get any nice exception object we can extract information from. isHandleIsInvalidException :: SomeException -> Bool isHandleIsInvalidException e = "the handle is invalid" `isInfixOf` e_string || "invalid handle" `isInfixOf` e_string where e_string = map toLower (show e) 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) cursorUpCode _ = "" cursorDownCode _ = "" cursorForwardCode _ = "" cursorBackwardCode _ = "" 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) cursorDownLineCode _ = "" cursorUpLineCode _ = "" hSetCursorColumn h x = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) setCursorColumnCode _ = "" 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) setCursorPositionCode _ _ = "" 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 }) clearFromCursorToScreenEndCode = "" clearFromCursorToScreenBeginningCode = "" clearScreenCode = "" clearFromCursorToLineEndCode = "" clearFromCursorToLineBeginningCode = "" clearLineCode = "" 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 scrollPageUpCode _ = "" scrollPageDownCode _ = "" {-# 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' setSGRCode _ = "" 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 hideCursorCode = "" showCursorCode = "" -- 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 setTitleCode _ = "" ansi-terminal-0.6.2.3/System/Console/ANSI/Unix.hs0000644000000000000000000000742512422731647017530 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module System.Console.ANSI.Unix ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Common import System.IO import Data.List #include "Common-Include.hs" -- | The reference I used for the ANSI escape characters in this module was . csi :: [Int] -> String -> String csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code 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 -> 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 n = csi [n] "A" cursorDownCode n = csi [n] "B" cursorForwardCode n = csi [n] "C" cursorBackwardCode n = csi [n] "D" 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 cursorDownLineCode n = csi [n] "E" cursorUpLineCode n = csi [n] "F" hCursorDownLine h n = hPutStr h $ cursorDownLineCode n hCursorUpLine h n = hPutStr h $ cursorUpLineCode n setCursorColumnCode n = csi [n + 1] "G" setCursorPositionCode n m = csi [n + 1, m + 1] "H" hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m clearFromCursorToScreenEndCode = csi [0] "J" clearFromCursorToScreenBeginningCode = csi [1] "J" clearScreenCode = csi [2] "J" hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode hClearScreen h = hPutStr h clearScreenCode clearFromCursorToLineEndCode = csi [0] "K" clearFromCursorToLineBeginningCode = csi [1] "K" clearLineCode = csi [2] "K" hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode hClearLine h = hPutStr h clearLineCode scrollPageUpCode n = csi [n] "S" scrollPageDownCode n = csi [n] "T" hScrollPageUp h n = hPutStr h $ scrollPageUpCode n hScrollPageDown h n = hPutStr h $ scrollPageDownCode n setSGRCode sgrs = csi (map sgrToCode sgrs) "m" hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs hideCursorCode = csi [] "?25l" showCursorCode = csi [] "?25h" hHideCursor h = hPutStr h hideCursorCode hShowCursor h = hPutStr h showCursorCode -- | 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 title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007" hSetTitle h title = hPutStr h $ setTitleCode titleansi-terminal-0.6.2.3/LICENSE0000644000000000000000000000276612253056123013630 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.2.3/Setup.lhs0000644000000000000000000000011512253056123014415 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMainansi-terminal-0.6.2.3/ansi-terminal.cabal0000644000000000000000000000645412574225775016371 0ustar0000000000000000Name: ansi-terminal Version: 0.6.2.3 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 Other-Modules: System.Console.ANSI.Common Include-Dirs: includes Build-Depends: base >= 4 && < 5 if os(windows) Build-Depends: Win32 >= 2.0 Cpp-Options: -DWINDOWS Extra-Libraries: "kernel32" Other-Modules: System.Console.ANSI.Windows System.Console.ANSI.Windows.Foreign System.Console.ANSI.Windows.Emulator -- NB: used for fallback by the emulator System.Console.ANSI.Unix else -- We assume any non-Windows platform is Unix Build-Depends: unix >= 2.3.0.0 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 if os(windows) Build-Depends: Win32 >= 2.0 Cpp-Options: -DWINDOWS Extra-Libraries: "kernel32" Other-Modules: System.Console.ANSI.Windows System.Console.ANSI.Windows.Foreign System.Console.ANSI.Windows.Emulator else -- We assume any non-Windows platform is Unix Build-Depends: unix >= 2.3.0.0 Cpp-Options: -DUNIX Other-Modules: System.Console.ANSI.Unix Build-Depends: base >= 4 && < 5 Extensions: CPP ForeignFunctionInterface Ghc-Options: -Wall if !flag(example) Buildable: False ansi-terminal-0.6.2.3/includes/Common-Include.hs0000644000000000000000000001357012565355112017577 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 () cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: Int -- ^ Number of lines or characters to move -> String 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 () cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move -> String 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 () setCursorColumnCode :: Int -- ^ 0-based column to move to -> String 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 () setCursorPositionCode :: Int -- ^ 0-based row to move to -> Int -- ^ 0-based column to move to -> String setCursorPosition = hSetCursorPosition stdout hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen :: Handle -> IO () clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: IO () clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout clearScreen = hClearScreen stdout hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine :: Handle -> IO () clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: IO () clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String 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 scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by -> String 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 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 setSGR = hSetSGR stdout hHideCursor, hShowCursor :: Handle -> IO () hideCursor, showCursor :: IO () hideCursorCode, showCursorCode :: String 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 () -- | Set the terminal window title setTitleCode :: String -- ^ New title -> String 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@ (whcih 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.2.3/includes/Exports-Include.hs0000644000000000000000000000274312422716246020014 0ustar0000000000000000-- * Basic data types module System.Console.ANSI.Common, -- * Cursor movement by character cursorUp, cursorDown, cursorForward, cursorBackward, hCursorUp, hCursorDown, hCursorForward, hCursorBackward, cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode, -- * Cursor movement by line cursorUpLine, cursorDownLine, hCursorUpLine, hCursorDownLine, cursorUpLineCode, cursorDownLineCode, -- * Directly changing cursor position setCursorColumn, hSetCursorColumn, setCursorColumnCode, setCursorPosition, hSetCursorPosition, setCursorPositionCode, -- * Clearing parts of the screen 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.2.3/CHANGELOG.md0000644000000000000000000000113712574225773014442 0ustar0000000000000000Changes ======= 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.2.3/README.md0000644000000000000000000000544112332717672014106 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.