diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ Changes ======= +Version 0.7.1 +------------- + +* Allow saving, restoring, and querying the current cursor position +* Fix a couple of issues with the Reset emulation on Windows + Version 0.7 ----------- diff --git a/System/Console/ANSI.hs b/System/Console/ANSI.hs --- a/System/Console/ANSI.hs +++ b/System/Console/ANSI.hs @@ -25,8 +25,8 @@ -- 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 +-- before being output. The use of these codes is generally discouraged +-- because they 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 diff --git a/System/Console/ANSI/Codes.hs b/System/Console/ANSI/Codes.hs --- a/System/Console/ANSI/Codes.hs +++ b/System/Console/ANSI/Codes.hs @@ -25,6 +25,9 @@ -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode + -- * Saving, restoring and reporting cursor position + , saveCursorCode, restoreCursorCode, reportCursorPositionCode + -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode @@ -133,6 +136,11 @@ -> Int -- ^ 0-based column to move to -> String setCursorPositionCode n m = csi [n + 1, m + 1] "H" + +saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String +saveCursorCode = "\ESC7" +restoreCursorCode = "\ESC8" +reportCursorPositionCode = csi [] "6n" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String diff --git a/System/Console/ANSI/Example.hs b/System/Console/ANSI/Example.hs --- a/System/Console/ANSI/Example.hs +++ b/System/Console/ANSI/Example.hs @@ -14,11 +14,13 @@ examples = [ cursorMovementExample , lineChangeExample , setCursorPositionExample + , saveRestoreCursorExample , clearExample , scrollExample , sgrExample , cursorVisibilityExample , titleExample + , getCursorPositionExample ] main :: IO () @@ -46,25 +48,25 @@ 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 @@ -78,13 +80,13 @@ pause -- Line One -- Line Two - + cursorUpLine 1 putStr "New Line One" pause -- New Line One -- Line Two - + cursorDownLine 1 putStr "New Line Two" pause @@ -98,25 +100,46 @@ 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 +saveRestoreCursorExample :: IO () +saveRestoreCursorExample = do + putStr "Start sentence ..." + pause + -- Start sentence ... + + saveCursor + setCursorPosition 2 3 + putStr "SPLASH!" + pause + -- Start sentence ... + -- + -- SPLASH! + + restoreCursor + putStr " end sentence, uninterrupted." + pause + -- Start sentence ... end sentence, uninterrupted + -- + -- SPLASH! + clearExample :: IO () clearExample = do putStrLn "Line One" @@ -124,50 +147,50 @@ 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 -- @@ -181,7 +204,7 @@ -- Line One -- Line Two -- Line Three - + scrollPageDown 2 pause -- @@ -189,7 +212,7 @@ -- Line One -- Line Two -- Line Three - + scrollPageUp 3 pause -- Line Two @@ -207,7 +230,7 @@ putStrLn (show color) pause -- All the colors, 4 times in sequence - + let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") , (SetConsoleIntensity FaintIntensity, "Faint") , (SetConsoleIntensity NormalIntensity, "Normal") @@ -228,16 +251,16 @@ 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" @@ -249,11 +272,11 @@ putStr "Cursor Demo" pause -- Cursor Demo| - + hideCursor pause -- Cursor Demo - + showCursor pause -- Cursor Demo| @@ -265,9 +288,31 @@ -- ~/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 + +getCursorPositionExample :: IO () +getCursorPositionExample = do + putStrLn " 11111111112222222222" + putStrLn "12345678901234567890123456789" + putStr "Report cursor position here:" + pause + -- 11111111112222222222 + -- 12345678901234567890123456789 + -- Report cursor position here:| + result <- getCursorPosition + putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n" + case result of + Just (row, col) -> putStrLn $ "The cursor was at row number " ++ + show row ++ " and column number " ++ show col ++ ".\n" + Nothing -> putStrLn "Error: unable to get the cursor position\n" + pause + -- 11111111112222222222 + -- 12345678901234567890123456789 + -- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R. + -- + -- The cursor was at row number 3 and column number 29. diff --git a/System/Console/ANSI/Unix.hs b/System/Console/ANSI/Unix.hs --- a/System/Console/ANSI/Unix.hs +++ b/System/Console/ANSI/Unix.hs @@ -1,13 +1,29 @@ {-# OPTIONS_HADDOCK hide #-} + module System.Console.ANSI.Unix ( +-- This file contains code that is common to modules +-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module +-- exports and the associated Haddock documentation. #include "Exports-Include.hs" ) where +import Control.Exception.Base (bracket) import System.Console.ANSI.Codes import System.Console.ANSI.Types -import System.IO (Handle, hIsTerminalDevice, hPutStr, stdout) +import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho, + hIsTerminalDevice, hPutStr, hSetBuffering, hSetEcho, stdin, stdout) +import Text.ParserCombinators.ReadP (readP_to_S) +-- This file contains code that is common to modules System.Console.ANSI.Unix, +-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as +-- type signatures and the definition of functions specific to stdout in terms +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. #include "Common-Include.hs" +-- This file contains code that is common save that different code is required +-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file +-- Common-Include-Emulator.hs in respect of the latter). +#include "Common-Include-Enabled.hs" hCursorUp h n = hPutStr h $ cursorUpCode n hCursorDown h n = hPutStr h $ cursorDownCode n @@ -20,6 +36,10 @@ hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m +hSaveCursor h = hPutStr h saveCursorCode +hRestoreCursor h = hPutStr h restoreCursorCode +hReportCursorPosition h = hPutStr h reportCursorPositionCode + hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode hClearScreen h = hPutStr h clearScreenCode @@ -37,3 +57,40 @@ hShowCursor h = hPutStr h showCursorCode hSetTitle h title = hPutStr h $ setTitleCode title + +-- getReportedCursorPosition :: IO String +-- (See Common-Include.hs for Haddock documentation) +getReportedCursorPosition = bracket (hGetEcho stdin) (hSetEcho stdin) $ const get + where + get = do + c <- getChar + if c == '\ESC' + then get' [c] + else return [c] -- If the first character is not the expected + -- \ESC then give up. This provides a modicom of + -- protection against unexpected data in the + -- input stream. + get' s = do + c <- getChar + if c /= 'R' + then get' (c:s) -- Continue building the list, until the expected 'R' + -- character is obtained. Build the list in reverse + -- order, in order to avoid O(n^2) complexity. + else return $ reverse (c:s) -- Reverse the order of the built list. + +-- getCursorPosition :: IO (Maybe (Int, Int)) +-- (See Common-Include.hs for Haddock documentation) +getCursorPosition = do + input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do + hSetBuffering stdin NoBuffering -- set no buffering (the contents of the + -- buffer will be discarded, so this + -- needs to be done before the cursor + -- positon is emitted) + reportCursorPosition + hFlush stdout -- ensure the report cursor position code is sent to the + -- operating system + getReportedCursorPosition + case readP_to_S cursorPosition input of + [] -> return Nothing + [((row, col),_)] -> return $ Just (row, col) + (_:_) -> return Nothing diff --git a/System/Console/ANSI/Windows.hs b/System/Console/ANSI/Windows.hs --- a/System/Console/ANSI/Windows.hs +++ b/System/Console/ANSI/Windows.hs @@ -1,136 +1,146 @@ {-# OPTIONS_HADDOCK hide #-} + module System.Console.ANSI.Windows ( +-- This file contains code that is common to modules +-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module +-- exports and the associated Haddock documentation. #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 System.Console.ANSI.Windows.Detect (ANSIEnabledStatus (..), + ConsoleDefaultState (..), isANSIEnabled) import qualified System.Console.ANSI.Windows.Emulator as E import System.IO (Handle, hIsTerminalDevice, stdout) +-- This file contains code that is common to modules System.Console.ANSI.Unix, +-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as +-- type signatures and the definition of functions specific to stdout in terms +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. #include "Common-Include.hs" +-- This file contains code that is common save that different code is required +-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file +-- Common-Include-Emulator.hs in respect of the latter). +#include "Common-Include-Enabled.hs" --- * Cursor movement by character -hCursorUp = if isANSIEnabled then U.hCursorUp else E.hCursorUp +-- | A helper function which returns the native or emulated version, depending +-- on `isANSIEnabled`. +nativeOrEmulated :: a -> a -> a +nativeOrEmulated native emulated = case isANSIEnabled of + ANSIEnabled -> native + NotANSIEnabled _ -> emulated -hCursorDown = if isANSIEnabled then U.hCursorDown else E.hCursorDown +-- | A helper function which returns the native or emulated version, depending +-- on `isANSIEnabled`, where the emulator uses the default console state. +nativeOrEmulatedWithDefault :: a -> (ConsoleDefaultState -> a) -> a +nativeOrEmulatedWithDefault native emulated = case isANSIEnabled of + ANSIEnabled -> native + NotANSIEnabled def -> emulated def -hCursorForward = if isANSIEnabled then U.hCursorForward else E.hCursorForward -hCursorBackward = if isANSIEnabled then U.hCursorBackward else E.hCursorBackward +-- * Cursor movement by character +hCursorUp = nativeOrEmulated U.hCursorUp E.hCursorUp +hCursorDown = nativeOrEmulated U.hCursorDown E.hCursorDown +hCursorForward = nativeOrEmulated U.hCursorForward E.hCursorForward +hCursorBackward = nativeOrEmulated U.hCursorBackward E.hCursorBackward cursorUpCode :: Int -> String -cursorUpCode = if isANSIEnabled then U.cursorUpCode else E.cursorUpCode +cursorUpCode = nativeOrEmulated U.cursorUpCode E.cursorUpCode cursorDownCode :: Int -> String -cursorDownCode = if isANSIEnabled then U.cursorDownCode else E.cursorDownCode +cursorDownCode = nativeOrEmulated U.cursorDownCode E.cursorDownCode cursorForwardCode :: Int -> String -cursorForwardCode = if isANSIEnabled - then U.cursorForwardCode - else E.cursorForwardCode +cursorForwardCode = nativeOrEmulated U.cursorForwardCode E.cursorForwardCode cursorBackwardCode :: Int -> String -cursorBackwardCode = if isANSIEnabled - then U.cursorBackwardCode - else E.cursorBackwardCode +cursorBackwardCode = nativeOrEmulated U.cursorBackwardCode E.cursorBackwardCode -- * Cursor movement by line -hCursorUpLine = if isANSIEnabled then U.hCursorUpLine else E.hCursorUpLine - -hCursorDownLine = if isANSIEnabled then U.hCursorDownLine else E.hCursorDownLine +hCursorUpLine = nativeOrEmulated U.hCursorUpLine E.hCursorUpLine +hCursorDownLine = nativeOrEmulated U.hCursorDownLine E.hCursorDownLine cursorUpLineCode :: Int -> String -cursorUpLineCode = if isANSIEnabled - then U.cursorUpLineCode - else E.cursorUpLineCode +cursorUpLineCode = nativeOrEmulated U.cursorUpLineCode E.cursorUpLineCode cursorDownLineCode :: Int -> String -cursorDownLineCode = if isANSIEnabled - then U.cursorDownLineCode - else E.cursorDownLineCode +cursorDownLineCode = nativeOrEmulated U.cursorDownLineCode E.cursorDownLineCode -- * Directly changing cursor position -hSetCursorColumn = if isANSIEnabled - then U.hSetCursorColumn - else E.hSetCursorColumn +hSetCursorColumn = nativeOrEmulated U.hSetCursorColumn E.hSetCursorColumn setCursorColumnCode :: Int -> String -setCursorColumnCode = if isANSIEnabled - then U.setCursorColumnCode - else E.setCursorColumnCode +setCursorColumnCode = nativeOrEmulated + U.setCursorColumnCode E.setCursorColumnCode -hSetCursorPosition = if isANSIEnabled - then U.hSetCursorPosition - else E.hSetCursorPosition +hSetCursorPosition = nativeOrEmulated U.hSetCursorPosition E.hSetCursorPosition setCursorPositionCode :: Int -> Int -> String -setCursorPositionCode = if isANSIEnabled - then U.setCursorPositionCode - else E.setCursorPositionCode +setCursorPositionCode = nativeOrEmulated + U.setCursorPositionCode E.setCursorPositionCode --- * Clearing parts of the screen -hClearFromCursorToScreenEnd = if isANSIEnabled - then U.hClearFromCursorToScreenEnd - else E.hClearFromCursorToScreenEnd +-- * Saving, restoring and reporting cursor position +hSaveCursor = nativeOrEmulated U.hSaveCursor E.hSaveCursor +hRestoreCursor = nativeOrEmulated U.hRestoreCursor E.hRestoreCursor +hReportCursorPosition = nativeOrEmulated + U.hReportCursorPosition E.hReportCursorPosition -hClearFromCursorToScreenBeginning = if isANSIEnabled - then U.hClearFromCursorToScreenBeginning - else E.hClearFromCursorToScreenBeginning +saveCursorCode :: String +saveCursorCode = nativeOrEmulated U.saveCursorCode E.saveCursorCode -hClearScreen = if isANSIEnabled then U.hClearScreen else E.hClearScreen +restoreCursorCode :: String +restoreCursorCode = nativeOrEmulated U.restoreCursorCode E.restoreCursorCode +reportCursorPositionCode :: String +reportCursorPositionCode = nativeOrEmulated + U.reportCursorPositionCode E.reportCursorPositionCode + +-- * Clearing parts of the screen +hClearFromCursorToScreenEnd = nativeOrEmulatedWithDefault + U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd +hClearFromCursorToScreenBeginning = nativeOrEmulatedWithDefault + U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning +hClearScreen = nativeOrEmulatedWithDefault U.hClearScreen E.hClearScreen + clearFromCursorToScreenEndCode :: String -clearFromCursorToScreenEndCode = if isANSIEnabled - then U.clearFromCursorToScreenEndCode - else E.clearFromCursorToScreenEndCode +clearFromCursorToScreenEndCode = nativeOrEmulated + U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode clearFromCursorToScreenBeginningCode :: String -clearFromCursorToScreenBeginningCode = - if isANSIEnabled - then U.clearFromCursorToScreenBeginningCode - else E.clearFromCursorToScreenBeginningCode +clearFromCursorToScreenBeginningCode = nativeOrEmulated + U.clearFromCursorToScreenBeginningCode 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 +clearScreenCode = nativeOrEmulated U.clearScreenCode E.clearScreenCode -hClearLine = if isANSIEnabled then U.hClearLine else E.hClearLine +hClearFromCursorToLineEnd = nativeOrEmulatedWithDefault + U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd +hClearFromCursorToLineBeginning = nativeOrEmulatedWithDefault + U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning +hClearLine = nativeOrEmulatedWithDefault U.hClearLine E.hClearLine clearFromCursorToLineEndCode :: String -clearFromCursorToLineEndCode = if isANSIEnabled - then U.clearFromCursorToLineEndCode - else E.clearFromCursorToLineEndCode +clearFromCursorToLineEndCode = nativeOrEmulated + U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode clearFromCursorToLineBeginningCode :: String -clearFromCursorToLineBeginningCode = if isANSIEnabled - then U.clearFromCursorToLineBeginningCode - else E.clearFromCursorToLineBeginningCode +clearFromCursorToLineBeginningCode = nativeOrEmulated + U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode clearLineCode :: String -clearLineCode = if isANSIEnabled then U.clearLineCode else E.clearLineCode +clearLineCode = nativeOrEmulated U.clearLineCode E.clearLineCode -- * Scrolling the screen -hScrollPageUp = if isANSIEnabled then U.hScrollPageUp else E.hScrollPageUp -hScrollPageDown = if isANSIEnabled then U.hScrollPageDown else E.hScrollPageDown +hScrollPageUp = nativeOrEmulatedWithDefault U.hScrollPageUp E.hScrollPageUp +hScrollPageDown = nativeOrEmulatedWithDefault U.hScrollPageDown E.hScrollPageDown scrollPageUpCode :: Int -> String -scrollPageUpCode = if isANSIEnabled - then U.scrollPageUpCode - else E.scrollPageUpCode +scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode scrollPageDownCode :: Int -> String -scrollPageDownCode = if isANSIEnabled - then U.scrollPageDownCode - else E.scrollPageDownCode +scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff -- @@ -145,24 +155,31 @@ -- 25 SetBlinkSpeed NoBlink -- 28 SetVisible True -hSetSGR = if isANSIEnabled then U.hSetSGR else E.hSetSGR +hSetSGR = nativeOrEmulatedWithDefault U.hSetSGR E.hSetSGR setSGRCode :: [SGR] -> String -setSGRCode = if isANSIEnabled then U.setSGRCode else E.setSGRCode +setSGRCode = nativeOrEmulated U.setSGRCode E.setSGRCode -- * Cursor visibilty changes -hHideCursor = if isANSIEnabled then U.hHideCursor else E.hHideCursor - -hShowCursor = if isANSIEnabled then U.hShowCursor else E.hShowCursor +hHideCursor = nativeOrEmulated U.hHideCursor E.hHideCursor +hShowCursor = nativeOrEmulated U.hShowCursor E.hShowCursor hideCursorCode :: String -hideCursorCode = if isANSIEnabled then U.hideCursorCode else E.hideCursorCode +hideCursorCode = nativeOrEmulated U.hideCursorCode E.hideCursorCode showCursorCode :: String -showCursorCode = if isANSIEnabled then U.showCursorCode else E.showCursorCode +showCursorCode = nativeOrEmulated U.showCursorCode E.showCursorCode -- * Changing the title -hSetTitle = if isANSIEnabled then U.hSetTitle else E.hSetTitle +hSetTitle = nativeOrEmulated U.hSetTitle E.hSetTitle setTitleCode :: String -> String -setTitleCode = if isANSIEnabled then U.setTitleCode else E.setTitleCode +setTitleCode = nativeOrEmulated U.setTitleCode E.setTitleCode + +-- getReportedCursorPosition :: IO String +-- (See Common-Include.hs for Haddock documentation) +getReportedCursorPosition = E.getReportedCursorPosition + +-- getCursorPosition :: IO (Maybe (Int, Int)) +-- (See Common-Include.hs for Haddock documentation) +getCursorPosition = E.getCursorPosition diff --git a/System/Console/ANSI/Windows/Detect.hs b/System/Console/ANSI/Windows/Detect.hs --- a/System/Console/ANSI/Windows/Detect.hs +++ b/System/Console/ANSI/Windows/Detect.hs @@ -2,23 +2,56 @@ module System.Console.ANSI.Windows.Detect ( - isANSIEnabled + ANSIEnabledStatus (..) +, ConsoleDefaultState (..) +, 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) +import Data.Bits ((.&.), (.|.)) +import System.Console.ANSI.Windows.Foreign (bACKGROUND_INTENSE_WHITE, + ConsoleException(..), CONSOLE_SCREEN_BUFFER_INFO (..), DWORD, + eNABLE_VIRTUAL_TERMINAL_PROCESSING, fOREGROUND_INTENSE_WHITE, + getConsoleMode, getConsoleScreenBufferInfo, getStdHandle, HANDLE, + iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, sTD_OUTPUT_HANDLE, WORD) -- '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. +-- | The default state of the console +data ConsoleDefaultState = ConsoleDefaultState + { defaultForegroundAttributes :: WORD -- ^ Foreground attributes + , defaultBackgroundAttributes :: WORD -- ^ Background attributes + } deriving (Eq, Show) + +-- | The status of the console as regards it being ANSI-enabled or not +-- ANSI-enabled. +data ANSIEnabledStatus + = ANSIEnabled -- ^ ANSI-enabled + | NotANSIEnabled ConsoleDefaultState -- ^ Not ANSI-enabled (including the + -- state of the console when that + -- status was determined) + deriving (Eq, Show) + +-- | This function assumes that once it is first established whether or not the +-- Windows console is ANSI-enabled, that will not change. If the console is not +-- ANSI-enabled, the state of the console is considered to be its default state. {-# NOINLINE isANSIEnabled #-} -isANSIEnabled :: Bool -isANSIEnabled = unsafePerformIO safeIsANSIEnabled +isANSIEnabled :: ANSIEnabledStatus +isANSIEnabled = unsafePerformIO $ do + e <- safeIsANSIEnabled + if e + then return ANSIEnabled + else do + hOut <- getValidStdHandle sTD_OUTPUT_HANDLE + info <- getConsoleScreenBufferInfo hOut + let attributes = csbi_attributes info + fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE + bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE + consoleDefaultState = ConsoleDefaultState + { defaultForegroundAttributes = fgAttributes + , defaultBackgroundAttributes = bgAttributes } + return $ NotANSIEnabled consoleDefaultState -- 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 diff --git a/System/Console/ANSI/Windows/Emulator.hs b/System/Console/ANSI/Windows/Emulator.hs --- a/System/Console/ANSI/Windows/Emulator.hs +++ b/System/Console/ANSI/Windows/Emulator.hs @@ -1,25 +1,41 @@ +{-# OPTIONS_HADDOCK hide #-} + module 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.Detect import System.Console.ANSI.Windows.Foreign import System.Console.ANSI.Windows.Emulator.Codes import System.IO +import System.IO.Unsafe (unsafePerformIO) -import Control.Exception (catchJust) +import Control.Exception (catch, catchJust, IOException) +import Control.Monad (forM_, unless) import Data.Colour (Colour) import Data.Colour.Names (black, blue, cyan, green, grey, lime, magenta, maroon, navy, olive, purple, red, silver, teal, white, yellow) import Data.Colour.SRGB (RGB (..), toSRGB) import Data.Bits +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List - +import Data.Maybe (mapMaybe) +import qualified Data.Map.Strict as Map +import Text.ParserCombinators.ReadP (readP_to_S) +-- This file contains code that is common to modules System.Console.ANSI.Unix, +-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as +-- type signatures and the definition of functions specific to stdout in terms +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. #include "Common-Include.hs" - +-- This file contains code that is required in the case of the module +-- System.Console.ANSI.Windows.Emulator and differs from the common code in +-- file Common-Include-Enabled.hs. +#include "Common-Include-Emulator.hs" withHandle :: Handle -> (HANDLE -> IO a) -> IO a withHandle handle action = do @@ -72,70 +88,105 @@ clearChar :: WCHAR clearChar = charToWCHAR ' ' -clearAttribute :: WORD -clearAttribute = 0 +-- | The 'clear' attribute is equated with the default background attributes. +clearAttribute :: ConsoleDefaultState -> WORD +clearAttribute = defaultBackgroundAttributes -hClearScreenFraction :: HANDLE -> (SMALL_RECT -> COORD -> (DWORD, COORD)) -> IO () -hClearScreenFraction handle fraction_finder = do +hClearScreenFraction + :: ConsoleDefaultState + -> HANDLE + -> (SMALL_RECT -> COORD -> (SHORT, SHORT, SHORT, SHORT, SHORT, SHORT)) + -> IO () +hClearScreenFraction cds 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 () + (left, top, right, bottom, start_x, end_x) + = fraction_finder window cursor_pos + mapM_ (fill_line left top right bottom start_x end_x) [top .. bottom] + where + fill_line left top right bottom start_x end_x y = do + let left' = if y == top then start_x else left + right' = if y == bottom then end_x else right + fill_cursor_pos = COORD left' y + fill_length = fromIntegral $ right' - left' + 1 + fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos + fillConsoleOutputAttribute handle (clearAttribute cds) fill_length fill_cursor_pos -hClearFromCursorToScreenEnd h = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go +hClearFromCursorToScreenEnd cds h + = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go where - go window cursor_pos = (fromIntegral fill_length, cursor_pos) + go window cursor_pos = (left, top, right, bottom, start_x, right) 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 + SMALL_RECT (COORD left _) (COORD right bottom) = window + COORD start_x top = cursor_pos -hClearFromCursorToScreenBeginning h = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go +hClearFromCursorToScreenBeginning cds h + = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go where - go window cursor_pos = (fromIntegral fill_length, rect_top_left window) + go window cursor_pos = (left, top, right, bottom, left, end_x) 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 + SMALL_RECT (COORD left top) (COORD right _) = window + COORD end_x bottom = cursor_pos -hClearScreen h = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ \handle -> hClearScreenFraction handle go +hClearScreen cds h + = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go where - go window _ = (fromIntegral fill_length, rect_top_left window) + go window _ = (left, top, right, bottom, left, right) where - size_x = rect_width window - size_y = rect_height window - fill_length = size_x * size_y + SMALL_RECT (COORD left top) (COORD right bottom) = window -hClearFromCursorToLineEnd h = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go +hClearFromCursorToLineEnd cds h + = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go where - go window cursor_pos = (fromIntegral (rect_right window - coord_x cursor_pos), cursor_pos) + go window cursor_pos = (left, y, right, y, start_x, right) + where + SMALL_RECT (COORD left _) (COORD right _) = window + COORD start_x y = cursor_pos -hClearFromCursorToLineBeginning h = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go +hClearFromCursorToLineBeginning cds h + = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go where - go window cursor_pos = (fromIntegral (coord_x cursor_pos), cursor_pos { coord_x = rect_left window }) + go window cursor_pos = (left, y, right, y, left, end_x) + where + SMALL_RECT (COORD left _) (COORD right _) = window + COORD end_x y = cursor_pos -hClearLine h = emulatorFallback (Unix.hClearLine h) $ withHandle h $ \handle -> hClearScreenFraction handle go +hClearLine cds h + = emulatorFallback (Unix.hClearLine h) $ withHandle h $ + \handle -> hClearScreenFraction cds handle go where - go window cursor_pos = (fromIntegral (rect_width window), cursor_pos { coord_x = rect_left window }) + go window cursor_pos = (left, y, right, y, left, right) + where + SMALL_RECT (COORD left _) (COORD right _) = window + COORD _ y = cursor_pos -hScrollPage :: HANDLE -> Int -> IO () -hScrollPage handle new_origin_y = do +hScrollPage + :: ConsoleDefaultState -- ^ The default console state + -> HANDLE + -> Int + -> IO () +hScrollPage cds handle new_origin_y = do screen_buffer_info <- getConsoleScreenBufferInfo handle - let fill = CHAR_INFO clearChar clearAttribute + let fill = CHAR_INFO clearChar (clearAttribute cds) 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 +hScrollPageUp cds h n + = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $ + \handle -> hScrollPage cds handle (negate n) +hScrollPageDown cds h n + = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $ + \handle -> hScrollPage cds handle n + {-# INLINE applyANSIColorToAttribute #-} applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of @@ -164,9 +215,9 @@ 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 +applyANSISGRToAttribute :: WORD -> SGR -> WORD -> WORD +applyANSISGRToAttribute def sgr attribute = case sgr of + Reset -> def SetConsoleIntensity intensity -> case intensity of BoldIntensity -> attribute .|. iNTENSITY FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported @@ -206,10 +257,12 @@ where iNTENSITY = fOREGROUND_INTENSITY -hSetSGR h sgr = emulatorFallback (Unix.hSetSGR h sgr) $ withHandle h $ \handle -> do +hSetSGR cds 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 + def = defaultForegroundAttributes cds + .|. defaultBackgroundAttributes cds + attribute' = foldl' (flip $ applyANSISGRToAttribute def) attribute -- make [] equivalent to [Reset], as documented (if null sgr then [Reset] else sgr) setConsoleTextAttribute handle attribute' @@ -227,6 +280,44 @@ -- 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 +cursorPositionRef :: IORef (Map.Map HANDLE COORD) +{-# NOINLINE cursorPositionRef #-} +cursorPositionRef = unsafePerformIO $ newIORef Map.empty + +hSaveCursor h = emulatorFallback (Unix.hSaveCursor h) $ withHandle h $ \handle -> do + screen_buffer_info <- getConsoleScreenBufferInfo handle + m <- readIORef cursorPositionRef + writeIORef cursorPositionRef + (Map.insert handle (csbi_cursor_position screen_buffer_info) m) + +hRestoreCursor h = emulatorFallback (Unix.hRestoreCursor h) $ withHandle h $ \handle -> do + m <- readIORef cursorPositionRef + let result = Map.lookup handle m + forM_ result (setConsoleCursorPosition handle) + +hReportCursorPosition h = emulatorFallback (Unix.hReportCursorPosition h) $ withHandle h $ \handle -> do + result <- getConsoleScreenBufferInfo handle + let (COORD cx cy) = csbi_cursor_position result + window = csbi_window result + x = cx - rect_left window + 1 + y = cy - rect_top window + 1 + hIn <- getStdHandle sTD_INPUT_HANDLE + _ <- writeConsoleInput hIn $ keyPresses $ + "\ESC[" ++ show y ++ ";" ++ show x ++ "R" + return () + +keyPress :: Char -> [INPUT_RECORD] +keyPress c = [keyDown, keyUp] + where + keyDown = key True + keyUp = key False + c' = UnicodeAsciiChar $ charToWCHAR c + key isDown = INPUT_RECORD kEY_EVENT $ + InputKeyEvent (KEY_EVENT_RECORD isDown 1 0 0 c' 0) + +keyPresses :: String -> [INPUT_RECORD] +keyPresses = concatMap keyPress + aNSIColors :: [((ColorIntensity, Color), Colour Float)] aNSIColors = [ ((Dull, Black), black) , ((Dull, Blue), navy) @@ -255,3 +346,53 @@ dg = g' - g db = b' - b in dr * dr + dg * dg + db * db + +-- getReportedCursorPosition :: IO String +-- (See Common-Include.hs for Haddock documentation) +getReportedCursorPosition = catch getReportedCursorPosition' getCPExceptionHandler + where + getReportedCursorPosition' = withHandleToHANDLE stdin action + where + action hdl = do + n <- getNumberOfConsoleInputEvents hdl + if n == 0 + then return "" + else do + es <- readConsoleInput hdl n + return $ stringFromInputEvents es + stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents + wCharsFromInputEvents = mapMaybe wCharFromInputEvent + wCharFromInputEvent e = if isKeyDownEvent + then Just (unicodeAsciiChar $ keyEventChar keyEventRecord) + else Nothing + where + eventType = inputEventType e + InputKeyEvent keyEventRecord = inputEvent e + isKeyDown = keyEventKeyDown keyEventRecord + isKeyDownEvent = eventType == 1 && isKeyDown + +-- getCursorPosition :: IO (Maybe (Int, Int)) +-- (See Common-Include.hs for Haddock documentation) +getCursorPosition = catch getCursorPosition' getCPExceptionHandler + where + getCursorPosition' = do + withHandleToHANDLE stdin flush -- Flush the console input buffer + reportCursorPosition + hFlush stdout -- ensure the report cursor position code is sent to the + -- operating system + input <- getReportedCursorPosition + case readP_to_S cursorPosition input of + [] -> return Nothing + [((row, col),_)] -> return $ Just (row, col) + (_:_) -> return Nothing + where + flush hdl = do + n <- getNumberOfConsoleInputEvents hdl + unless (n == 0) (void $ readConsoleInput hdl n) + +getCPExceptionHandler :: IOException -> IO a +getCPExceptionHandler e = error msg + where + msg = "Error: " ++ show e ++ "\nThis error may be avoided by using a " ++ + "console based on the Win32 console of the Windows API, such as " ++ + "Command Prompt or PowerShell." diff --git a/System/Console/ANSI/Windows/Emulator/Codes.hs b/System/Console/ANSI/Windows/Emulator/Codes.hs --- a/System/Console/ANSI/Windows/Emulator/Codes.hs +++ b/System/Console/ANSI/Windows/Emulator/Codes.hs @@ -11,6 +11,9 @@ -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode + -- * Saving, restoring and reporting cursor position + , saveCursorCode, restoreCursorCode, reportCursorPositionCode + -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode @@ -51,6 +54,11 @@ -> Int -- ^ 0-based column to move to -> String setCursorPositionCode _ _ = "" + +saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String +saveCursorCode = "" +restoreCursorCode = "" +reportCursorPositionCode = "" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String diff --git a/System/Console/ANSI/Windows/Foreign.hs b/System/Console/ANSI/Windows/Foreign.hs --- a/System/Console/ANSI/Windows/Foreign.hs +++ b/System/Console/ANSI/Windows/Foreign.hs @@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} -- | "System.Win32.Console" is really very impoverished, so I have had to do all the FFI myself. @@ -7,8 +8,13 @@ BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, - charToWCHAR, + -- 'Re-exports from System.Win32.Console.Extra' + INPUT_RECORD(..), INPUT_RECORD_EVENT(..), kEY_EVENT, + KEY_EVENT_RECORD(..), UNICODE_ASCII_CHAR (..), writeConsoleInput, + getNumberOfConsoleInputEvents, readConsoleInput, + charToWCHAR, cWcharsToChars, + COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, rect_width, rect_height, CONSOLE_CURSOR_INFO(..), CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), @@ -38,7 +44,6 @@ withTString, withHandleToHANDLE, - -- ConsoleException(..) ) where @@ -118,6 +123,7 @@ coord_x :: SHORT, coord_y :: SHORT } + deriving (Read, Eq) instance Show COORD where show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" @@ -260,6 +266,13 @@ fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY +kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, fOCUS_EVENT :: WORD +kEY_EVENT = 1 +mOUSE_EVENT = 2 +wINDOW_BUFFER_SIZE_EVENT = 4 +mENU_EVENT = 8 +fOCUS_EVENT = 16 + 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 @@ -275,6 +288,10 @@ 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 +foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW" cWriteConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents" cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" cReadConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL + data ConsoleException = ConsoleException !ErrCode deriving (Show, Eq, Typeable) instance Exception ConsoleException @@ -380,3 +397,240 @@ withStablePtr :: a -> (StablePtr a -> IO b) -> IO b withStablePtr value = bracket (newStablePtr value) freeStablePtr #endif + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console, cut down for the WCHAR version of writeConsoleInput. + +writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD +writeConsoleInput hdl evs = + writeConsoleInputWith hdl $ \act -> withArrayLen evs $ \len ptr -> act (ptr, toEnum len) + +writeConsoleInputWith :: HANDLE -> InputHandler (Ptr INPUT_RECORD, DWORD) -> IO DWORD +writeConsoleInputWith hdl withBuffer = + returnWith_ $ \ptrN -> + withBuffer $ \(ptrBuf, len) -> + failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN + +returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a +returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr + +type InputHandler i = forall a. (i -> IO a) -> IO a + +{- +typedef union _UNICODE_ASCII_CHAR { + WCHAR UnicodeChar; + CHAR AsciiChar; +} UNICODE_ASCII_CHAR; +-} +newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar { unicodeAsciiChar :: WCHAR } + deriving (Show, Read, Eq) + +instance Storable UNICODE_ASCII_CHAR where + sizeOf _ = 2 + alignment _ = 2 + peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr + poke ptr val = case val of + UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c + +{- +typedef struct _KEY_EVENT_RECORD { + BOOL bKeyDown; + WORD wRepeatCount; + WORD wVirtualKeyCode; + WORD wVirtualScanCode; + union { + WCHAR UnicodeChar; + CHAR AsciiChar; + } uChar; + DWORD dwControlKeyState; +} +#ifdef __GNUC__ +/* gcc's alignment is not what win32 expects */ + PACKED +#endif +KEY_EVENT_RECORD; +-} +data KEY_EVENT_RECORD = KEY_EVENT_RECORD { + keyEventKeyDown :: BOOL, + keyEventRepeatCount :: WORD, + keyEventVirtualKeyCode :: WORD, + keyEventVirtualScanCode :: WORD, + keyEventChar :: UNICODE_ASCII_CHAR, + keyEventControlKeystate :: DWORD + } deriving (Show, Read, Eq) + +instance Storable KEY_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 6) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 10) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ keyEventKeyDown val + (`pokeByteOff` 4) ptr $ keyEventRepeatCount val + (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val + (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val + (`pokeByteOff` 10) ptr $ keyEventChar val + (`pokeByteOff` 12) ptr $ keyEventControlKeystate val + +{- +typedef struct _MOUSE_EVENT_RECORD { + COORD dwMousePosition; + DWORD dwButtonState; + DWORD dwControlKeyState; + DWORD dwEventFlags; +} MOUSE_EVENT_RECORD; +-} +data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD { + mousePosition :: COORD, + mouseButtonState :: DWORD, + mouseControlKeyState :: DWORD, + mouseEventFlags :: DWORD + } deriving (Show, Read, Eq) + +instance Storable MOUSE_EVENT_RECORD where + sizeOf _ = 16 + alignment _ = 4 + peek ptr = + MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr + <*> (`peekByteOff` 4) ptr + <*> (`peekByteOff` 8) ptr + <*> (`peekByteOff` 12) ptr + poke ptr val = do + (`pokeByteOff` 0) ptr $ mousePosition val + (`pokeByteOff` 4) ptr $ mouseButtonState val + (`pokeByteOff` 8) ptr $ mouseControlKeyState val + (`pokeByteOff` 12) ptr $ mouseEventFlags val + +{- +typedef struct _WINDOW_BUFFER_SIZE_RECORD { + COORD dwSize; +} WINDOW_BUFFER_SIZE_RECORD; +-} +data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD { + bufSizeNew :: COORD + } deriving (Show, Read, Eq) + +instance Storable WINDOW_BUFFER_SIZE_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val + +{- +typedef struct _MENU_EVENT_RECORD { + UINT dwCommandId; +} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; +-} +data MENU_EVENT_RECORD = MENU_EVENT_RECORD { + menuCommandId :: UINT + } deriving (Show, Read, Eq) + +instance Storable MENU_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val + +{- +typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; +-} +data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD { + focusSetFocus :: BOOL + } deriving (Show, Read, Eq) + +instance Storable FOCUS_EVENT_RECORD where + sizeOf _ = 4 + alignment _ = 4 + peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr + poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val + +data INPUT_RECORD_EVENT + = InputKeyEvent KEY_EVENT_RECORD + | InputMouseEvent MOUSE_EVENT_RECORD + | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD + | InputMenuEvent MENU_EVENT_RECORD + | InputFocusEvent FOCUS_EVENT_RECORD + deriving (Show, Read, Eq) + +{- +typedef struct _INPUT_RECORD { + WORD EventType; + union { + KEY_EVENT_RECORD KeyEvent; + MOUSE_EVENT_RECORD MouseEvent; + WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; + MENU_EVENT_RECORD MenuEvent; + FOCUS_EVENT_RECORD FocusEvent; + } Event; +} INPUT_RECORD,*PINPUT_RECORD; +-} +data INPUT_RECORD = INPUT_RECORD { + inputEventType :: WORD, + inputEvent :: INPUT_RECORD_EVENT + } deriving (Show, Read, Eq) + +instance Storable INPUT_RECORD where + sizeOf _ = 20 + alignment _ = 4 + peek ptr = do + evType <- (`peekByteOff` 0) ptr + event <- case evType of + _ | evType == kEY_EVENT + -> InputKeyEvent <$> (`peekByteOff` 4) ptr + _ | evType == mOUSE_EVENT + -> InputMouseEvent <$> (`peekByteOff` 4) ptr + _ | evType == wINDOW_BUFFER_SIZE_EVENT + -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr + _ | evType == mENU_EVENT + -> InputMenuEvent <$> (`peekByteOff` 4) ptr + _ | evType == fOCUS_EVENT + -> InputFocusEvent <$> (`peekByteOff` 4) ptr + _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ show evType + return $ INPUT_RECORD evType event + poke ptr val = do + (`pokeByteOff` 0) ptr $ inputEventType val + case inputEvent val of + InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev + InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev + InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev + InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev + InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console. + +getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD +getNumberOfConsoleInputEvents hdl = + returnWith_ $ \ptrN -> + failIfFalse_ "GetNumberOfConsoleInputEvents" $ cGetNumberOfConsoleInputEvents hdl ptrN + +-- The following is based on module System.Win32.Console.Extra from package +-- Win32-console, cut down for the WCHAR version of readConsoleInput. + +readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] +readConsoleInput hdl len = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr + +readConsoleInputWith :: HANDLE -> DWORD -> OutputHandler (Ptr INPUT_RECORD, DWORD) +readConsoleInputWith hdl len handler = + allocaArray (fromEnum len) $ \ptrBuf -> + alloca $ \ptrN -> do + failIfFalse_ "ReadConsoleInputW" $ cReadConsoleInput hdl ptrBuf len ptrN + n <- peek ptrN + handler (ptrBuf, n) + +type OutputHandler o = forall a. (o -> IO a) -> IO a + +-- Replicated from module Foreign.C.String in package base because that module +-- does not export the function. +cWcharsToChars :: [CWchar] -> [Char] +cWcharsToChars = map chr . fromUTF16 . map fromIntegral + where + fromUTF16 (c1:c2:wcs) + | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = + ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs + fromUTF16 (c:wcs) = c : fromUTF16 wcs + fromUTF16 [] = [] diff --git a/ansi-terminal.cabal b/ansi-terminal.cabal --- a/ansi-terminal.cabal +++ b/ansi-terminal.cabal @@ -1,10 +1,11 @@ Name: ansi-terminal -Version: 0.7 +Version: 0.7.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. Works on UNIX and Windows. +Description: ANSI terminal support for Haskell: allows cursor movement, + screen clearing, color output, showing or hiding the + cursor, and changing the title. Works on UNIX and Windows. License: BSD3 License-File: LICENSE Author: Max Bolingbroke @@ -13,6 +14,8 @@ Build-Type: Simple Extra-Source-Files: includes/Common-Include.hs + includes/Common-Include-Emulator.hs + includes/Common-Include-Enabled.hs includes/Exports-Include.hs CHANGELOG.md README.md @@ -36,6 +39,7 @@ , colour if os(windows) Build-Depends: base-compat >= 0.9.1 + , containers , Win32 >= 2.0 , process Cpp-Options: -DWINDOWS @@ -68,6 +72,7 @@ if os(windows) Build-Depends: base-compat >= 0.9.1 + , containers , Win32 >= 2.0 Cpp-Options: -DWINDOWS Other-Modules: System.Console.ANSI.Windows diff --git a/includes/Common-Include-Emulator.hs b/includes/Common-Include-Emulator.hs new file mode 100644 --- /dev/null +++ b/includes/Common-Include-Emulator.hs @@ -0,0 +1,65 @@ +-- This file contains code that is required in the case of the module +-- System.Console.ANSI.Windows.Emulator and differs from the common code in +-- file Common-Include-Enabled.hs. + +-- | Set the Select Graphic Rendition mode +hSetSGR + :: ConsoleDefaultState -- ^ The default console state + -> 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 + :: ConsoleDefaultState -- ^ The default console state + -> [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 () +setSGR def = hSetSGR def stdout + +hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen + :: ConsoleDefaultState -- ^ The default console state + -> Handle + -> IO () + +clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen + :: ConsoleDefaultState -- ^ The default console state + -> IO () +clearFromCursorToScreenEnd def = hClearFromCursorToScreenEnd def stdout +clearFromCursorToScreenBeginning def + = hClearFromCursorToScreenBeginning def stdout +clearScreen def = hClearScreen def stdout + +hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine + :: ConsoleDefaultState -- ^ The default console state + -> Handle + -> IO () + +clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine + :: ConsoleDefaultState -- ^ The default console state + -> IO () +clearFromCursorToLineEnd def = hClearFromCursorToLineEnd def stdout +clearFromCursorToLineBeginning def = hClearFromCursorToLineBeginning def stdout +clearLine def = hClearLine def stdout + +-- | Scroll the displayed information up or down the terminal: not widely +-- supported +hScrollPageUp, hScrollPageDown + :: ConsoleDefaultState -- ^ The default console state + -> Handle + -> Int -- ^ Number of lines to scroll by + -> IO () + +-- | Scroll the displayed information up or down the terminal: not widely +-- supported +scrollPageUp, scrollPageDown + :: ConsoleDefaultState -- ^ The default console state + -> Int -- ^ Number of lines to scroll by + -> IO () +scrollPageUp def = hScrollPageUp def stdout +scrollPageDown def = hScrollPageDown def stdout diff --git a/includes/Common-Include-Enabled.hs b/includes/Common-Include-Enabled.hs new file mode 100644 --- /dev/null +++ b/includes/Common-Include-Enabled.hs @@ -0,0 +1,56 @@ +-- This file contains code that is common save that different code is required +-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file +-- Common-Include-Emulator.hs in respect of the latter). + +-- | 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 () +setSGR = hSetSGR 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 () +scrollPageUp = hScrollPageUp stdout +scrollPageDown = hScrollPageDown stdout diff --git a/includes/Common-Include.hs b/includes/Common-Include.hs --- a/includes/Common-Include.hs +++ b/includes/Common-Include.hs @@ -1,13 +1,25 @@ +-- This file contains code that is common to modules System.Console.ANSI.Unix, +-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as +-- type signatures and the definition of functions specific to stdout in terms +-- of the corresponding more general functions, inclduding the related Haddock +-- documentation. + import 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 () +import Control.Monad (void) +import Data.Char (isDigit) +import Text.ParserCombinators.ReadP (char, many1, ReadP, satisfy) + +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 @@ -37,45 +49,33 @@ -> 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 +hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () --- | 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 +-- | Save the cursor position in memory. The only way to access the saved value +-- is with the 'restoreCursor' command. +saveCursor :: IO () +-- | Restore the cursor position from memory. There will be no value saved in +-- memory until the first use of the 'saveCursor' command. +restoreCursor :: IO () +-- | Looking for a way to get the cursors position? See +-- 'getCursorPosition'. +-- +-- Emit the cursor position into the console input stream, immediately after +-- being recognised on the output stream, as: +-- @ESC [ \ ; \ R@ +-- +-- In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this +-- function may be of limited use on Windows operating systems because of +-- difficulties in obtaining the data emitted into the console input stream. +-- The function 'hGetBufNonBlocking' in module "System.IO" does not work on +-- Windows. This has been attributed to the lack of non-blocking primatives in +-- the operating system (see the GHC bug report #806 at +-- ). +reportCursorPosition :: IO () --- | 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 +saveCursor = hSaveCursor stdout +restoreCursor = hRestoreCursor stdout +reportCursorPosition = hReportCursorPosition stdout hHideCursor, hShowCursor :: Handle -> IO () @@ -105,3 +105,60 @@ where -- cannot use lookupEnv since it only appeared in GHC 7.6 isDumb = maybe False (== "dumb") . lookup "TERM" <$> getEnvironment + +-- | Parses the characters emitted by 'reportCursorPosition' into the console +-- input stream. Returns the cursor row and column as a tuple. +-- +-- For example, if the characters emitted by 'reportCursorPosition' are in +-- 'String' @input@ then the parser could be applied like this: +-- +-- > let result = readP_to_S cursorPosition input +-- > case result of +-- > [] -> putStrLn $ "Error: could not parse " ++ show input +-- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row +-- > ++ " and column" ++ show column ++ "." +-- > (_:_) -> putStrLn $ "Error: parse not unique" +-- +cursorPosition :: ReadP (Int, Int) +cursorPosition = do + void $ char '\ESC' + void $ char '[' + row <- decimal -- A non-negative whole decimal number + void $ char ';' + col <- decimal -- A non-negative whole decimal number + void $ char 'R' + return (read row, read col) + where + digit = satisfy isDigit + decimal = many1 digit + +-- | Attempts to get the reported cursor position data from the console input +-- stream. The function is intended to be called immediately after +-- 'reportCursorPosition' (or related functions) have caused characters to be +-- emitted into the stream. +-- +-- For example, on a Unix-like operating system: +-- +-- > hSetBuffering stdin NoBuffering -- set no buffering (the contents of the +-- > -- buffer will be discarded, so this needs +-- > -- to be done before the cursor positon is +-- > -- emitted) +-- > reportCursorPosition +-- > hFlush stdout -- ensure the report cursor position code is sent to the +-- > -- operating system +-- > input <- getReportedCursorPosition +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Win32 console of the Windows API. +-- (Command Prompt and PowerShell are based on the Win32 console.) +getReportedCursorPosition :: IO String + +-- | Attempts to get the reported cursor position, combining the functions +-- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'. +-- Returns 'Nothing' if any data emitted by 'reportCursorPosition', obtained by +-- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'. +-- +-- On Windows operating systems, the function is not supported on consoles, such +-- as mintty, that are not based on the Win32 console of the Windows API. +-- (Command Prompt and PowerShell are based on the Win32 console.) +getCursorPosition :: IO (Maybe (Int, Int)) diff --git a/includes/Exports-Include.hs b/includes/Exports-Include.hs --- a/includes/Exports-Include.hs +++ b/includes/Exports-Include.hs @@ -1,3 +1,7 @@ +-- This file contains code that is common to modules +-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module +-- exports and the associated Haddock documentation. + -- * Basic data types module System.Console.ANSI.Types, @@ -27,6 +31,19 @@ hSetCursorPosition, setCursorPositionCode, +-- * Saving, restoring and reporting cursor position +saveCursor, +hSaveCursor, +saveCursorCode, + +restoreCursor, +hRestoreCursor, +restoreCursorCode, + +reportCursorPosition, +hReportCursorPosition, +reportCursorPositionCode, + -- * Clearing parts of the screen -- | Note that these functions only clear parts of the screen. They do not move the -- cursor. @@ -59,4 +76,9 @@ setTitleCode, -- * Checking if handle supports ANSI -hSupportsANSI +hSupportsANSI, + +-- * Getting the cursor position +getCursorPosition, +getReportedCursorPosition, +cursorPosition